434-zeusmp Report

**434-zeusmp**
Exec Time (%)	Codelet Name	Error (%)
98.8	zeusmp_fppized_MAIN___659	96.8
5.6	hsmoc_hsmoc__837	6.2
2.5	tranx1_tranx1__530	0.9
3.4	tranx2_tranx2__526	0.9
3.3	lorentz_lorentz__441	4.8
10.8	hsmoc_hsmoc__1334	6.7
6.4	hsmoc_hsmoc__1140	0.9
3.0	forces_forces__466	0.3
2.6	lorentz_lorentz__741	2.9
8.8	advx3_advx3__637	1.8
6.0	momx3_momx3__401	13.9
4.5	tranx3_tranx3__530	9.6
4.5	tranx3_tranx3__530	9.6
2.3	hsmoc_hsmoc__780	1.1
5.6	hsmoc_hsmoc__971	4.4
3.7	lorentz_lorentz__638	8.4
3.4	lorentz_lorentz__539	18.9
2.3	avisc_avisc__384	6.1
1.6	newdt_newdt__421	2.4
6.0	momx3_momx3__401	13.9
4.6	hsmoc_hsmoc__671	1.3
1.2	lorentz_lorentz__421	7.2
5.1	momx2_momx2__396	4.9
1.0	lorentz_lorentz__1042	25.2
4.4	momx1_momx1__391	4.0
5.9	lorentz_lorentz__840	7.2
2.3	hsmoc_hsmoc__611	8.4

Exec Time : 2.833833e+10 cycles

Matching : 84.8%

                












































































c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////                 M O M X 1                 \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
       subroutine momx1 (ibeg,iend,jbeg,jend,kbeg,kend
     &                  ,s1,s2,s3,mflx)
c
c    dac:zeus3d.momx1 <--------------- transports momenta in 1-direction
c    from jms:zeus2d.momx1, mln:zeus04.momz                    may, 1990
c
c    written by: David Clarke
c    modified 1: November, 1992 by David Clarke; momenta are now updated
c                between and including i=is,ie, j=js,je, and k=ks,ke to
c                allow for proper treatment of periodic boundaries.
c    modified 2: Feb. 20, 1996 by Robert Fiedler; completely rewritten
c                for ZEUS-MP
c
c  PURPOSE:  Transports the three components of the momentum density in
c  the 1-direction using the consistent transport algorithm, including
c  the effects of grid compression.  The transported fluxes are thus
c  given by the mass fluxes times the time centred area of the control
c  volume faces times the interpolated velocities.  Interpolations are
c  performed in-line.
c
c  INPUT VARIABLES:
c    mflx    mass flux in 1-direction (computed in TRANX1)
c    s1      momentum density in 1-direction
c    s2      momentum density in 2-direction
c    s3      momentum density in 3-direction
c
c BOUNDARY VALUES USED:
c
c    Macro defined  var   ii    oi    ij    oj    ik    ok
c    -------------  ---  ----  ----  ----  ----  ----  ----
c                  mflx  is-1  ie+1  js-1        ks-1
c                    u1  is-2  ie+2  js-1        ks-1
c                    u2  is-2  ie+2
c                    u3  is-2  ie+2
c
c  OUTPUT VARIABLES:
c    s1      momentum density in 1-direction updated in the 1-direction
c    s2      momentum density in 2-direction updated in the 1-direction
c    s3      momentum density in 3-direction updated in the 1-direction
c
c  LOCAL VARIABLES:
c    vel     velocity used for upwinding in interpolation routine
c    vtwid   interpolated velocity
c    sflx    momentum fluxes
c
c  EXTERNALS:
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj

c
       integer i,j,k,ibeg,iend,jbeg,jend,kbeg,kend
       real*8        dqm, dqp, xi, q1, vel
c
       real*8        atwid1 (ijkn), atwid2 (ijkn), atwid3 (ijkn)
       real*8        vtwid   ( ijkn ), sflx  ( ijkn )
     1             , dq   ( ijkn )
c
       real*8        mflx    (  in,  jn,  kn), s1      (  in,  jn,  kn)
     1             , s2      (  in,  jn,  kn), s3      (  in,  jn,  kn)
c
       equivalence   ( atwid1  , w1da     ), ( dq      , w1db )

       equivalence   ( vtwid   , w1dc     )
     1             , ( vel     , sflx    , w1dd    )

c
c      External statements
c
c---------------------------- TRANSPORT S1 -----------------------------
c
c      Compute time-centred area factors.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
       do 10 i=ibeg-1,iend+1

         atwid1(i) = 0.5 * g2b (i) * g31b (i)
         atwid2(i) = 0.5 * g2a (i) * g2a  (i) * g31a (i)
         atwid3(i) = 0.5 * g31a(i) * g2a  (i) * g31a (i)

10     continue
       do 590 k=kbeg,kend
         do 580 j=jbeg,jend
c
c      Interpolate "v1" at the zone centres.
c
c       call x1fc3d ( v1, vel1, js, ks, je, ke, iords1, vtwid1 )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 70 i=ibeg-1,iend+1
             dqm        = (v1 (i  ,j,k) - v1 (i-1,j,k)) * dx1ai(i-1)
             dqp        = (v1 (i+1,j,k) - v1 (i  ,j,k)) * dx1ai(i  )
             dq(i)      = max ( dqm * dqp, zro )
     1                  * sign ( one, dqm + dqp )
     2                  / max ( abs ( dqm + dqp ), tiny )
70         continue
c
c  2.  Choose time averaged, upwinded interface value.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 100 i=ibeg-1,iend
c
c      Construct an i-average of "v1-vg1" to be used for interpolation.
c
             vel        = 0.5 * ( v1(i  ,j,k) - vg1(i  )
     1                          + v1(i+1,j,k) - vg1(i+1) )
              xi        = vel         * dt
              q1        = sign ( haf, xi )
              vtwid (i) = ( 0.5 + q1 ) * ( v1 (i  ,j,k)
     1                  + ( dx1b(i  ) - xi ) * dq  (i      ) )
     2                  + ( 0.5 - q1 ) * ( v1 (i+1,j,k)
     3                  - ( dx1b(i+1) + xi ) * dq  (i+1    ) )
c
c      Construct the 1-momentum flux at the zone centres and perform
c  1-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
             sflx (i    ) = ( mflx (i,j,k) + mflx (i+1,j,k) )
     1                    * vtwid (i    ) * atwid1(i)
100        continue
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 170 i=ibeg,iend
             s1   (i,j,k) = ( s1(i,j,k) * dvl1b(i)
     1                    - sflx (i    ) + sflx (i-1    ) ) 

     2                    * dvl1b i(i)

170        continue
c
c---------------------------- TRANSPORT S2 -----------------------------
c
c      Interpolate "v2" at the 1-interfaces.
c
c       call x1zc3d ( v2, vel1, js, ks, je, ke, iords2, istps2
c     1             , vtwid1, p      )
c
c     1.  Evaluate monotonised, van Leer differences across the zone.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 270 i=ibeg-1,iend+1
             dqm       = (v2 (i  ,j,k) - v2 (i-1,j,k)) * dx1bi(i  )
             dqp       = (v2 (i+1,j,k) - v2 (i  ,j,k)) * dx1bi(i+1)
             dq(i)     = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
270        continue
c
c     2.  Choose time averaged, upwinded interface value.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 300 i=ibeg,iend+1
             vel       = 0.5 * ( v1(i,j-1,k) + v1(i,j,k) )
             xi        = ( vel         - vg1(i) ) * dt
             q1        = sign ( haf, xi )
             vtwid (i) = ( 0.5 + q1 ) * ( v2 (i-1,j,k)
     1                 + ( dx1a(i-1) - xi ) * dq   (i-1) )
     2                 + ( 0.5 - q1 ) * ( v2 (i  ,j,k)
     3                 - ( dx1a(i  ) + xi ) * dq   (i  ) )
c
c      Construct the 2-momentum flux at the 1-interfaces and perform
c  2-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
             sflx (i    ) = ( mflx (i,j-1,k) + mflx (i,j,k) )
     1                    * vtwid (i    ) * atwid2(i)
300        continue
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 370 i=ibeg,iend
             s2(i,j,k) = ( s2(i,j,k) * dvl1a(i)

     1                   - sflx (i+1    ) + sflx (i    ) ) * dvl1a i(i)

370        continue
c
c---------------------------- TRANSPORT S3 -----------------------------
c
c      Interpolate "v3" at the 1-interfaces.
c
c       call x1zc3d ( v3, vel1, js, ks, je, ke, iords3, istps3
c     1             , vtwid1, p      )
c
c     1.  Evaluate monotonised, van Leer differences across the zone.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 470 i=ibeg-1,iend+1
             dqm       = (v3 (i  ,j,k) - v3 (i-1,j,k)) * dx1bi(i  )
             dqp       = (v3 (i+1,j,k) - v3 (i  ,j,k)) * dx1bi(i+1)
             dq(i)     = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
470        continue
c
c     2.  Choose time averaged, upwinded interface value.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 500 i=ibeg,iend+1
c
c      Construct a k-average of "v1" to be used for interpolation.
c
             vel       = 0.5 * ( v1(i,j,k-1) + v1(i,j,k) )
             xi        = ( vel         - vg1(i) ) * dt
             q1        = sign ( haf, xi )
             vtwid (i) = ( 0.5 + q1 ) * ( v3 (i-1,j,k)
     1                 + ( dx1a(i-1) - xi ) * dq   (i-1) )
     2                 + ( 0.5 - q1 ) * ( v3 (i  ,j,k)
     3                 - ( dx1a(i  ) + xi ) * dq   (i  ) )
c
c      Construct the 3-momentum flux at the 1-interfaces and perform
c  3-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
             sflx (i    ) = ( mflx (i,j,k-1) + mflx (i,j,k) )
     1                    * vtwid (i    ) * g32b(j) * atwid3(i)
500        continue
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 570 i=ibeg,iend
             s3(i,j,k) = ( s3(i,j,k) * dvl1a(i)

     1                   - sflx (i+1    ) + sflx (i    ) ) * dvl1a i(i)

570        continue
580      continue
590    continue
c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////                 M O M X 1                 \\\\\\\\\\
c
c=======================================================================
c
c

invivomomx1_momx1__391

Real time: 1.252512e+09 -- Predicted time: 1.201426e+09

Callcount: 210

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
106	### 1	29.924492933886	2.346764e+07	2.709410e+07	13.3
2	### 2	59.169318128195	5.959892e+06	5.086000e+06	14.6
207	### 3	59.4847905522751	1.384868e+06	1.439500e+06	3.7
26	### 4	60.0820663824754	1.067664e+06	9.739920e+05	8.7

                












































































c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////                F O R C E S                \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
       subroutine forces (ibeg,iend,jbeg,jend,kbeg,kend
     &                   ,u1,u2,u3,w1,w2,w3)

c
c
c Computes Pressure, Gravity, and Pseudo-Rotational Forces.

c   and includes magnetic pressure forces (longitudinal Lorentz forces)

c
c Arrays u1 , u2 , u3  hold the old velocity values, while
c        w1 , w2 , w3  receive the updated values.
c
c BOUNDARY VALUES USED:
c
c  Macro defined  var   ii    oi    ij    oj    ik    ok
c  -------------  ---  ----  ----  ----  ----  ----  ----
c                  d   is-1        js-1        ks-1
c  ZRP             d   is-1        js-1        ks-1  ke+1
c  RTP             d   is-1        js-1  je+1  ks-1  ke+1
c                  e   is-1        js-1        ks-1
c  TOTAL_ENERGY    u1  is-1  ie+1  js-1        ks-1
c  RTP             u2  is-1              je+1
c  TOTAL_ENERGY    u2  is-1        js-1  je+1  ks-1
c  TOTAL_ENERGY    u3  is-1        js-1        ks-1  ke+1
c  ZRP             u3              js-1              ke+1
c  RTP             u3  is-1        js-1              ke+1
c  RAD || RAD_EXP  er  is-1        js-1        ks-1
c               b1  is-1  ie+1  js-1  je+1  ks-1  ke+1
c               b2  is-1  ie+1  js-1  je+1  ks-1  ke+1
c               b3  is-1  ie+1  js-1  je+1  ks-1  ke+1
c Written by RAF; modified 3/13/97 (JCH); 
c     modified 2 Mar 1998 to add  (M-MML)
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj



      real*8    g,tgrav,ptmass,x1ptm,x2ptm,x3ptm,
     &        rt_fn_grv,rt_co_grv,wgt_grv

      integer mi_fn_grv,mi_co_grv,m_grv,nu_pr_grv,nu_po_grv,
     &        vv_grv,sl_fn_grv,sl_co_grv,smth_grv
CPS


      common /gravcomr/ g,tgrav,ptmass,x1ptm,x2ptm,x3ptm,
     &        rt_fn_grv,rt_co_grv,wgt_grv

      common /gravcomi/ mi_fn_grv,mi_co_grv,m_grv,nu_pr_grv,nu_po_grv,
     &        vv_grv,sl_fn_grv,sl_co_grv,smth_grv
CPS





      integer stat, req


      logical periodic(3)
      logical reorder
      integer myid, myid_w, nprocs, nprocs_w, coords(3)
      integer ierr, nreq, nsub
      integer comm3d
      integer ntiles(3)
      integer n1m, n1p, n2m, n2p, n3m, n3p
      integer i_slice,j_slice,k_slice
      integer ils_slice,jls_slice,kls_slice
      integer ilsm_slice,jlsm_slice,klsm_slice
      integer ibuf_in(nbuff), ibuf_out(nbuff)
      real*8    buf_in(nbuff), buf_out(nbuff)
      common /mpicomi/ myid, myid_w, nprocs, nprocs_w, coords
     &               , comm3d, ntiles
     &               , n1m, n1p, n2m, n2p, n3m, n3p
     &               , i_slice, j_slice, k_slice
     &               , ils_slice, jls_slice, kls_slice
     &               , ilsm_slice, jlsm_slice, klsm_slice
     &               , ibuf_in, ibuf_out
     &               , stat, req, ierr, nreq, nsub
      common /mpicoml/ periodic, reorder
      common /mpicomr/ buf_in, buf_out

      real*8 clight,me,mp,mh,boltz,h,guniv
      real*8 msol,lsol
      real*8 cmau,cmpc,cmkpc,cmkm,everg
      real*8 rad_con,mmw,gasc,sbc
c   physical constants (cgs)
      data clight  /2.99792e10     /,
     &     me      /9.10953e-28    /,
     &     mp      /1.67265e-24    /,
     &     mh      /1.66053e-24    /,
     &     boltz   /1.38066e-16    /,
     &     rad_con /7.56000e-15    /,
     &     h       /6.62618e-27    /,
     &     guniv   /6.6720e-8      /,
     &     mmw     /1.0            /,
     &     gasc    /8.625e7        /,
     &     sbc     /1.8044e-5      /
c   astronomical constants (cgs)
      data msol    /1.989e33       /,
     &     lsol    /3.826e33       /
c   conversion factors
      data cmau    /1.49597e13     /,
     &     cmpc    /3.084e18       /,
     &     cmkpc   /3.084e21       /,
     &     cmkm    /1.0e5          /,
     &     everg   /1.60219e-12    /

       integer ibeg,iend,jbeg,jend,kbeg,kend
       integer i,j,k
       real*8 u1 (in,jn,kn),u2 (in,jn,kn),u3 (in,jn,kn)
     &     ,w1 (in,jn,kn),w2 (in,jn,kn),w3 (in,jn,kn)
       real*8 poo(in),pmo(in),pom(in)
       real*8 st,rhoi




       real*8 d1b2oo(in), d1b3oo(in), d2b1oo(in), d2b3oo(in)
     &     ,d3b1oo(in), d3b2oo(in)
       real*8 d1b2po(in), d1b3op(in), d2b1po(in), d2b3op(in)
     &     ,d3b1po(in), d3b2op(in)




c
c-----------------------------------------------------------------------
c
c Main loop for pressure, magnetic pressure, self-gravity, and
c     rotational pseudo-forces.  
c
c Active zones for all velocity components are (is:ie, js:je, ks:ke).
c
c In its most general configuration, this loop needs 1 layer of 
c boundary data for each of d, e, u1, u2, u3, and gp.
c
c If GRAV or GRAV_FFT is not defined, we don't need gp.
c If ISO  is     defined, we don't need e .
c
c For  defined and TOTAL_ENERGY not defined, we don't need u1,u2,u3
c boundary values.  All we do need in this case is the inner boundary 
c data for d (and e).
c
c Of course, TOTAL_ENERGY and ISO are mutually exclusive. 
c
c **> at the moment, TOTAL_ENERGY and  also can't be used together
c       (M-MML 4 Mar 98)
c
c#if defined RAD || defined RAD_EXP
c       call opacity(e, d, gamma, kap, sig, dkapdt,
c     .              ibeg-1, iend, jbeg, jend, kbeg, kend)
c#endif 
c
       do 40 k=kbeg,kend
         do 30 j=jbeg,jend
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 10 i=ibeg-1,iend
c
c Compute thermal pressure
c


               poo(i)         = gamm1 * ( e(i  ,j  ,k  ) + efloor )
               pmo(i)         = gamm1 * ( e(i  ,j-1,k  ) + efloor )
               pom(i)         = gamm1 * ( e(i  ,j  ,k-1) + efloor )



c.......................................................................
c   


 10        continue
c.......................................................................

c
c        Compute differences in the squares of the magnetic field
c        components for the longitudinal Lorentz forces.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 11 i=ibeg-1,iend
              d1b2oo(i) = ( ( g2b (i  ) * b2(i  ,j  ,k  ) )**2
     1                    - ( g2b (i-1) * b2(i-1,j  ,k  ) )**2 )
     2                     * g2ai (i) * g2ai (i)
              d1b2po(i) = ( ( g2b (i  ) * b2(i  ,j+1,k  ) )**2
     1                    - ( g2b (i-1) * b2(i-1,j+1,k  ) )**2 )
     2                     * g2ai (i) * g2ai (i)
              d1b3oo(i) = ( ( g31b(i  ) * b3(i  ,j  ,k  ) )**2
     1                    - ( g31b(i-1) * b3(i-1,j  ,k  ) )**2 )
     2                     * g31ai(i) * g31ai(i)
              d1b3op(i) = ( ( g31b(i  ) * b3(i  ,j  ,k+1) )**2
     1                    - ( g31b(i-1) * b3(i-1,j  ,k+1) )**2 )
     2                     * g31ai(i) * g31ai(i)
              d2b3oo(i) = ( ( g32b(j  ) * b3(i  ,j  ,k  ) )**2
     1                    - ( g32b(j-1) * b3(i  ,j-1,k  ) )**2 )
     2                     * g32ai(j) * g32ai(j)
              d2b3op(i) = ( ( g32b(j  ) * b3(i  ,j  ,k+1) )**2
     1                    - ( g32b(j-1) * b3(i  ,j-1,k+1) )**2 )
     2                     * g32ai(j) * g32ai(j)
              d2b1oo(i) = b1(i  ,j  ,k  ) * b1(i  ,j  ,k  )
     1                  - b1(i  ,j-1,k  ) * b1(i  ,j-1,k  )
              d2b1po(i) = b1(i+1,j  ,k  ) * b1(i+1,j  ,k  )
     1                  - b1(i+1,j-1,k  ) * b1(i+1,j-1,k  )
              d3b1oo(i) = b1(i  ,j  ,k  ) * b1(i  ,j  ,k  )
     1                  - b1(i  ,j  ,k-1) * b1(i  ,j  ,k-1)
              d3b1po(i) = b1(i+1,j  ,k  ) * b1(i+1,j  ,k  )
     1                  - b1(i+1,j  ,k-1) * b1(i+1,j  ,k-1)
              d3b2oo(i) = b2(i  ,j  ,k  ) * b2(i  ,j  ,k  )
     1                  - b2(i  ,j  ,k-1) * b2(i  ,j  ,k-1)
              d3b2op(i) = b2(i  ,j+1,k  ) * b2(i  ,j+1,k  )
     1                  - b2(i  ,j+1,k-1) * b2(i  ,j+1,k-1)
11         continue


CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 20 i=ibeg,iend
c.......................................................................
c
c Perform an explicit update for v1
c
             rhoi    = 2.0 / ( d(i-1,j,k) + d(i,j,k) )
c
c  1.  pressure gradient
c
             st      = - rhoi
     1               * ( poo(i)    - poo(i-1)    ) * dx1bi(i)




c

c
c  6. Magnetic pressure (longitudinal Lorentz force)
c
             st = st - (d1b2oo(i) + d1b2po(i) + d1b3oo(i) + d1b3op(i))
     3                 * rhoi * dx1bi(i) * 0.25


c
             w1(i,j,k) = u1(i,j,k) + dt * st
c.......................................................................
c
c Perform an explicit update for v2 
c
             rhoi    = 2.0 / ( d(i,j-1,k) + d(i,j,k) )
c
c  1.  pressure gradient
c
             st      = - rhoi
     1               * ( poo(i)     - pmo(i)     ) * dx2bi(j)
     2               * g2bi(i)




c

c
c  6. Magnetic pressure (longitudinal Lorentz force)
c
             st = st - (d2b3oo(i) + d2b3op(i) + d2b1oo(i) + d2b1po(i))
     3               * rhoi * dx2bi(j) * g2bi(i) * 0.25


c
             w2(i,j,k) = u2(i,j,k) + dt * st
c
c.......................................................................
c
c Perform an explicit update for v3
c
             rhoi    = 2.0 / ( d(i,j,k-1) + d(i,j,k) )
c
c  1.  pressure gradient
c
             st      = - rhoi
     1               * ( poo(i)    - pom(i)      ) * dx3bi(k)
     2               * g31bi(i) * g32bi(j)



c

c
c  6. Magnetic pressure (longitudinal Lorentz force)
c
             st = st - (d3b1oo(i) + d3b1po(i) + d3b2oo(i) + d3b2op(i))
     3               * rhoi * dx3bi(k) * g31bi(i) * g32bi(j) * 0.25


c
             w3(i,j,k) = u3(i,j,k) + dt * st
20         continue
30       continue
40     continue
c

       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////                F O R C E S                \\\\\\\\\\
c
c=======================================================================
c
c

invivoforces_forces__466

Real time: 8.746841e+08 -- Predicted time: 8.774390e+08

Callcount: 180

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
113	### 1	92.7232823433635	8.975134e+06	8.986604e+06	0.1
54	### 2	99.1021023146697	4.564500e+05	3.955640e+05	13.3

                












































































c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////                T R A N X 2                \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
       subroutine tranx2 (ibeg,iend,jbeg,jend,kbeg,kend
     &                   ,dlo,den

     &                   ,eod,edn


     &                   ,mflx)
c
c    dac:zeus3d.tranx2 <----- transports zone-centred variables along x2
c    from jms:zeus2d.tranx2, mln:zeus04.tranz                  may, 1990
c
c    written by: David Clarke
c    modified 1: June 1992, by David Clarke; added the total energy
c                option originally designed by Byung-IL Jun.
c    modified 2: Feb. 20, 1996 by Robert Fiedler; completely rewritten
c                for ZEUS-MP.
c    modified 3: Aug. 8, 1996 by Robert Fiedler; unrolled i-loops.
c    nodified 4: Dec. 23, 1996 by Robert Fiedler; added radiation.
c
c  PURPOSE:  Transports all zone centred variables in the 2-direction
c  only.  Currently transported are:
c
c                      mass   density
c                      energy density
c
c  The consistent advection algorithm, in which mass fluxes are used to
c  construct the fluxes of all variables across the interfaces, is used
c  for all hydrodynamical variables.  Thus, the mass fluxes are passed
c  to MOMX2 on order to transport the momenta as well.  The magnetic
c  field components are treated separately from the mass fluxes in CT.
c  Interpolations are done in-line.
c
c  INPUT VARIABLES: 
c    ibeg,iend,jbeg,jend,kbeg,kend  index ranges to cover.
c    dlo      mass            density at previous substep.
c    eod      specific energy density at previous substep; equals
c             (e+p)/d  if TOTAL_ENERGY is defined.
c    ero      specific radiation energy density at previous substep.
c
c BOUNDARY VALUES USED:
c
c    Macro defined  var   ii    oi    ij    oj    ik    ok
c    -------------  ---  ----  ----  ----  ----  ----  ----
c                    d   is-1        js-3  je+2  ks-1
c                   e/d              js-2  je+2
c    TOTAL_ENERGY    u1        ie+1                         
c                    u2  is-1        js-1  je+1  ks-1
c    TOTAL_ENERGY    u3                                ke+1
c
c  OUTPUT VARIABLES:
c    den      updated mass            density.
c    edn      updated specific energy density.
c    ern      updated specific radiation energy density.
c    mflx     mass flux (in the 2-direction)
c
c  LOCAL VARIABLES:
c    atwid    effective cross sectional area of the 1-interfaces
c    etwid    interpolated specific energy densities (e/d) at all
c             2-interfaces
c    rtwid    interpolated specific radiation energy densities at all
c             2-interfaces
c    eflx     energy density flux across all 2-interfaces  (reuse etwid)
c    dtwid    interpolated mass densities at all 2-interfaces
c    dflx     mass density flux across all 2-interfaces    (reuse dtwid)
c
c  EXTERNALS:
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj


      real*8     fiis(nbvar),  fois(nbvar)
     &      ,  fijs(nbvar),  fojs(nbvar)
     &      ,  fiks(nbvar),  foks(nbvar)
      integer  niis( 3),  nois( 3)
     &      ,  nijs( 3),  nojs( 3)
     &      ,  niks( 3),  noks( 3)
      integer  bvstat(6,nbvar)

      integer  niib(jn,kn), niib2(jn,kn), niib3(jn,kn), niib23(jn,kn)
     &      ,  noib(jn,kn), noib2(jn,kn), noib3(jn,kn), noib23(jn,kn)
     &      ,  nijb(in,kn), nijb3(in,kn), nijb1(in,kn), nijb31(in,kn)
     &      ,  nojb(in,kn), nojb3(in,kn), nojb1(in,kn), nojb31(in,kn)
     &      ,  nikb(in,jn), nikb1(in,jn), nikb2(in,jn), nikb12(in,jn)
     &      ,  nokb(in,jn), nokb1(in,jn), nokb2(in,jn), nokb12(in,jn)


      real*8    diib(jn,kn,3),  doib(jn,kn,3)
     &     ,  dijb(in,kn,3),  dojb(in,kn,3)
     &     ,  dikb(in,jn,3),  dokb(in,jn,3)
      real*8    eiib(jn,kn,2),  eoib(jn,kn,2)
     &     ,  eijb(in,kn,2),  eojb(in,kn,2)
     &     ,  eikb(in,jn,2),  eokb(in,jn,2)
      real*8   v1iib(jn,kn,2), v1oib(jn,kn,2)
     &     , v1ijb(in,kn,2), v1ojb(in,kn,2)
     &     , v1ikb(in,jn,2), v1okb(in,jn,2)
      real*8   v2iib(jn,kn,2), v2oib(jn,kn,2)
     &     , v2ijb(in,kn,2), v2ojb(in,kn,2)
     &     , v2ikb(in,jn,2), v2okb(in,jn,2)
      real*8   v3iib(jn,kn,2), v3oib(jn,kn,2)
     &     , v3ijb(in,kn,2), v3ojb(in,kn,2)
     &     , v3ikb(in,jn,2), v3okb(in,jn,2)

      real*8   b1iib(jn,kn,2), b1oib(jn,kn,2)
     &     , b1ijb(in,kn,2), b1ojb(in,kn,2)
     &     , b1ikb(in,jn,2), b1okb(in,jn,2)
      real*8   b2iib(jn,kn,2), b2oib(jn,kn,2)
     &     , b2ijb(in,kn,2), b2ojb(in,kn,2)
     &     , b2ikb(in,jn,2), b2okb(in,jn,2)
      real*8   b3iib(jn,kn,2), b3oib(jn,kn,2)
     &     , b3ijb(in,kn,2), b3ojb(in,kn,2)
     &     , b3ikb(in,jn,2), b3okb(in,jn,2)
      real*8   emf1iib(jn,kn,3), emf1oib(jn,kn,3)
     &     , emf1ijb(in,kn,3), emf1ojb(in,kn,3)
     &     , emf1ikb(in,jn,3), emf1okb(in,jn,3)
      real*8   emf2iib(jn,kn,3), emf2oib(jn,kn,3)
     &     , emf2ijb(in,kn,3), emf2ojb(in,kn,3)
     &     , emf2ikb(in,jn,3), emf2okb(in,jn,3)
      real*8   emf3iib(jn,kn,3), emf3oib(jn,kn,3)
     &     , emf3ijb(in,kn,3), emf3ojb(in,kn,3)
     &     , emf3ikb(in,jn,3), emf3okb(in,jn,3)




      common /bndryr/
     &   fiis,  fois,  fijs,  fojs,  fiks,  foks
     & , diib,  doib,  dijb,  dojb,  dikb,  dokb
     & , eiib,  eoib,  eijb,  eojb,  eikb,  eokb
     & ,v1iib, v1oib, v1ijb, v1ojb, v1ikb, v1okb
     & ,v2iib, v2oib, v2ijb, v2ojb, v2ikb, v2okb
     & ,v3iib, v3oib, v3ijb, v3ojb, v3ikb, v3okb

     & ,b1iib, b1oib, b1ijb, b1ojb, b1ikb, b1okb
     & ,b2iib, b2oib, b2ijb, b2ojb, b2ikb, b2okb
     & ,b3iib, b3oib, b3ijb, b3ojb, b3ikb, b3okb
     & ,emf1iib, emf1oib, emf1ijb, emf1ojb, emf1ikb, emf1okb
     & ,emf2iib, emf2oib, emf2ijb, emf2ojb, emf2ikb, emf2okb
     & ,emf3iib, emf3oib, emf3ijb, emf3ojb, emf3ikb, emf3okb




      common /bndryi/   niis,   nois,   nijs,   nojs,   niks,   noks
     &      ,  bvstat
     &      ,  niib, niib2, niib3, niib23
     &      ,  noib, noib2, noib3, noib23
     &      ,  nijb, nijb3, nijb1, nijb31
     &      ,  nojb, nojb3, nojb1, nojb31
     &      ,  nikb, nikb1, nikb2, nikb12
     &      ,  nokb, nokb1, nokb2, nokb12



      integer stat, req


      logical periodic(3)
      logical reorder
      integer myid, myid_w, nprocs, nprocs_w, coords(3)
      integer ierr, nreq, nsub
      integer comm3d
      integer ntiles(3)
      integer n1m, n1p, n2m, n2p, n3m, n3p
      integer i_slice,j_slice,k_slice
      integer ils_slice,jls_slice,kls_slice
      integer ilsm_slice,jlsm_slice,klsm_slice
      integer ibuf_in(nbuff), ibuf_out(nbuff)
      real*8    buf_in(nbuff), buf_out(nbuff)
      common /mpicomi/ myid, myid_w, nprocs, nprocs_w, coords
     &               , comm3d, ntiles
     &               , n1m, n1p, n2m, n2p, n3m, n3p
     &               , i_slice, j_slice, k_slice
     &               , ils_slice, jls_slice, kls_slice
     &               , ilsm_slice, jlsm_slice, klsm_slice
     &               , ibuf_in, ibuf_out
     &               , stat, req, ierr, nreq, nsub
      common /mpicoml/ periodic, reorder
      common /mpicomr/ buf_in, buf_out
c
       integer i, j, k, ibeg,iend,jbeg,jend,kbeg,kend
c
       real*8    dqm,dqp, xi,q1
       real*8        atwid (ijkn)
       equivalence (atwid , w1da)
c


       integer     iriter

       real*8        mflux (ijkn,4)
     &           , dtwid (ijkn,4),  dd    (ijkn,4)



       real*8        etwid (ijkn,4),  deod  (ijkn,4)



c
       real*8  dlo  (in,jn,kn), den  (in,jn,kn), mflx (in,jn,kn)

     &      ,eod  (in,jn,kn), edn  (in,jn,kn)


c
c-----------------------------------------------------------------------
c
c Compute time-centered area factors.
c
       do 10 i=ibeg-1,iend+1
         atwid (i)         = g31b(i) * dx1a(i) * dvl1ai(i)
10     continue
c
c Transport all zone-centered quantities in the 2 direction.
c
       do 2100 k=kbeg-1,kend
         if ( (k.ge.kbeg) .or. (k.eq.ks-1) ) then
c.......................................................................
c
c Split off the i=ibeg-1 iteration to ease unrolling.
c
           i = ibeg - 1
c
c   Interpolate to obtain zone-centered quantities at zone faces.
c
c     1.  Evaluate monotonised, van Leer differences across the zone.
c
           if (jbeg .eq. js) then  
c  Need d(js-3) from neighbor.
             j         = js - 2
             dqm       = (dlo(i,j  ,k) - dijb (i,k,3)) * dx2bi(j  )
             dqp       = (dlo(i,j+1,k) - dlo(i,j  ,k)) * dx2bi(j+1)
             dd  (j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c Not valid, but we don't use it.
             deod(j,1) = zro  


           endif
           do 30 j=max(jbeg-2,js-1),jend+1
             dqm       = (dlo(i,j  ,k) - dlo(i,j-1,k)) * dx2bi(j  )
             dqp       = (dlo(i,j+1,k) - dlo(i,j  ,k)) * dx2bi(j+1)
             dd  (j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )

             dqm       = (eod(i,j  ,k) - eod(i,j-1,k)) * dx2bi(j  )
             dqp       = (eod(i,j+1,k) - eod(i,j  ,k)) * dx2bi(j+1)
             deod(j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )


30         continue
c
c     2.  Choose time averaged, upwinded interface value.
c
c  For the purposes of consistent advection, construct the mass
c  flux across each 1-interface.  The mass flux will be used to create
c  the fluxes of all variables, including the momenta which are updated
c  in MOMX1.
c
             do 40 j=jbeg-1,jend+1
               xi         = ( v2  (i,j  ,k) - vg2(j  ) ) * dt
               q1         = sign ( haf, xi )
               dtwid (j,1)= ( 0.5 + q1 ) * ( dlo(i,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * dd   (j-1,1) )
     2                    + ( 0.5 - q1 ) * ( dlo(i,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * dd   (j  ,1) )
c
             mflux (j,1) = dtwid (j,1) * ( v2(i,j  ,k) - vg2(j  ) ) * dt

             dtwid (j,1) = mflux (j,1) * atwid (i) * g32a (j  )


               etwid (j,1)= ( 0.5 + q1 ) * ( eod(i,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * deod (j-1,1) )
     2                    + ( 0.5 - q1 ) * ( eod(i,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * deod (j  ,1) )
c
               etwid (j,1)= dtwid (j,1) * etwid (j,1)


40           continue
c
c  Save the mass flux outside (ibeg:iend,jbeg:jend,kbeg:kend)
c  only for zones next to the inner orders.
c
               if (i.eq.is-1) then

                 if (jbeg .eq. js) mflx(i,js-1,k) = mflux (js-1,1)
                 do 60 j=jbeg,jend
                   mflx(i,j,k) = mflux(j   ,1)
60               continue
                 if (jend .eq. je) mflx(i,je+1,k) = mflux (je+1,1)
c
               endif
c.......................................................................
c

c Do the iterations which will not be done in unrolled loops next.
c
           iriter = mod(iend-ibeg+1,4)
           do 1090 i=ibeg,ibeg+iriter-1

c
c   Interpolate to obtain zone-centered quantities at zone faces.
c
c     1.  Evaluate monotonised, van Leer differences across the zone.
c
           if (jbeg .eq. js) then  
c  Need d(js-3) from neighbor.
             j         = js - 2
             dqm       = (dlo(i,j  ,k) - dijb (i,k,3)) * dx2bi(j  )
             dqp       = (dlo(i,j+1,k) - dlo(i,j  ,k)) * dx2bi(j+1)
             dd  (j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c Not valid, but we don't use it.
             deod(j,1) = zro  


           endif
           do 1030 j=max(jbeg-2,js-1),jend+1
             dqm       = (dlo(i,j  ,k) - dlo(i,j-1,k)) * dx2bi(j  )
             dqp       = (dlo(i,j+1,k) - dlo(i,j  ,k)) * dx2bi(j+1)
             dd  (j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )

             dqm       = (eod(i,j  ,k) - eod(i,j-1,k)) * dx2bi(j  )
             dqp       = (eod(i,j+1,k) - eod(i,j  ,k)) * dx2bi(j+1)
             deod(j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )


1030       continue
c
c     2.  Choose time averaged, upwinded interface value.
c
c  For the purposes of consistent advection, construct the mass
c  flux across each 1-interface.  The mass flux will be used to create
c  the fluxes of all variables, including the momenta which are updated
c  in MOMX1.
c
             do 1040 j=jbeg-1,jend+1
               xi         = ( v2  (i,j  ,k) - vg2(j  ) ) * dt
               q1         = sign ( haf, xi )
               dtwid (j,1)= ( 0.5 + q1 ) * ( dlo(i,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * dd   (j-1,1) )
     2                    + ( 0.5 - q1 ) * ( dlo(i,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * dd   (j  ,1) )
c
             mflux (j,1) = dtwid (j,1) * ( v2(i,j  ,k) - vg2(j  ) ) * dt

             dtwid (j,1) = mflux (j,1) * atwid (i) * g32a (j  )


               etwid (j,1)= ( 0.5 + q1 ) * ( eod(i,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * deod (j-1,1) )
     2                    + ( 0.5 - q1 ) * ( eod(i,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * deod (j  ,1) )
c
               etwid (j,1)= dtwid (j,1) * etwid (j,1)


1040         continue
c
c  Save the mass flux outside (ibeg:iend,jbeg:jend,kbeg:kend)
c  only for zones next to the inner orders.
c
               if ( (i.eq.is-1 .and. k.ge.kbeg) .or.
     &              (i.ge.ibeg .and. k.eq.ks-1) .or.
     &              (i.eq.is-1 .and. k.eq.ks-1) ) then
                 if (jbeg .eq. js) mflx(i,js-1,k) = mflux (js-1,1)
                 do 1060 j=jbeg,jend
                   mflx(i,j,k) = mflux(j   ,1)
1060             continue
                 if (jend .eq. je) mflx(i,je+1,k) = mflux (je+1,1)
               endif
c
c  Perform mass density and energy density advection.  Note that
c  the timestep "dt" is hidden the fluxes "dflx" and "eflx".
c
             if (k.ge.kbeg .and. i.ge.ibeg) then
               if (jbeg .eq. js) mflx(i,js-1,k) = mflux (js-1,1)
               if (jend .eq. je) mflx(i,je+1,k) = mflux (je+1,1)
               do 1080 j=jbeg,jend
               mflx(i,j,k) = mflux (j,1)
               den(i,j,k) = ( dlo(i,j,k) * dvl2a(j)

     1                    - dtwid (j+1,1)  + dtwid (j,1)  ) * dvl2a i(j)


               e  (i,j,k) = ( e  (i,j,k) * dvl2a(j)

     1                    - etwid (j+1,1)  + etwid (j,1)  ) * dvl2a i(j)

c
c Compute e/d for the next substep.
c

               edn(i,j,k) = e(i,j,k) / den(i,j,k)



1080         continue
           endif
1090       continue
c
c.......................................................................
c

c Do the bulk of the iterations in unrolled loops.
c
           do 2090 i=ibeg+iriter,iend,4
c
c
c   Interpolate to obtain zone-centered quantities at zone faces.
c
c     1.  Evaluate monotonised, van Leer differences across the zone.
c
           if (jbeg .eq. js) then  
c  Need d(js-3) from neighbor.
             j         = js - 2
             dqm       = (dlo(i  ,j  ,k) - dijb (i  ,k,3)) * dx2bi(j  )
             dqp       = (dlo(i  ,j+1,k) - dlo(i  ,j  ,k)) * dx2bi(j+1)
             dd  (j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c Not valid, but we don't use it.
             deod(j,1) = zro  


c
             dqm       = (dlo(i+1,j  ,k) - dijb (i+1,k,3)) * dx2bi(j  )
             dqp       = (dlo(i+1,j+1,k) - dlo(i+1,j  ,k)) * dx2bi(j+1)
             dd  (j,2) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )

c Not valid, but we don't use it.
             deod(j,2) = zro  


c

             dqm       = (dlo(i  ,j  ,k) - dijb (i  ,k,3)) * dx2bi(j  )
             dqp       = (dlo(i+2,j+1,k) - dlo(i+2,j  ,k)) * dx2bi(j+1)
             dd  (j,3) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c Not valid, but we don't use it.
             deod(j,3) = zro  


c


             dqm       = (dlo(i+3,j  ,k) - dijb (i+3,k,3)) * dx2bi(j  )
             dqp       = (dlo(i+3,j+1,k) - dlo(i+3,j  ,k)) * dx2bi(j+1)
             dd  (j,4) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c Not valid, but we don't use it.
             deod(j,4) = zro  


c

           endif
           do 2030 j=max(jbeg-2,js-1),jend+1
             dqm       = (dlo(i  ,j  ,k) - dlo(i  ,j-1,k)) * dx2bi(j  )
             dqp       = (dlo(i  ,j+1,k) - dlo(i  ,j  ,k)) * dx2bi(j+1)
             dd  (j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )

             dqm       = (eod(i  ,j  ,k) - eod(i  ,j-1,k)) * dx2bi(j  )
             dqp       = (eod(i  ,j+1,k) - eod(i  ,j  ,k)) * dx2bi(j+1)
             deod(j,1) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )


c
             dqm       = (dlo(i+1,j  ,k) - dlo(i+1,j-1,k)) * dx2bi(j  )
             dqp       = (dlo(i+1,j+1,k) - dlo(i+1,j  ,k)) * dx2bi(j+1)
             dd  (j,2) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )

             dqm       = (eod(i+1,j  ,k) - eod(i+1,j-1,k)) * dx2bi(j  )
             dqp       = (eod(i+1,j+1,k) - eod(i+1,j  ,k)) * dx2bi(j+1)
             deod(j,2) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )


c

             dqm       = (dlo(i+2,j  ,k) - dlo(i+2,j-1,k)) * dx2bi(j  )
             dqp       = (dlo(i+2,j+1,k) - dlo(i+2,j  ,k)) * dx2bi(j+1)
             dd  (j,3) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )

             dqm       = (eod(i+2,j  ,k) - eod(i+2,j-1,k)) * dx2bi(j  )
             dqp       = (eod(i+2,j+1,k) - eod(i+2,j  ,k)) * dx2bi(j+1)
             deod(j,3) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )


c


             dqm       = (dlo(i+3,j  ,k) - dlo(i+3,j-1,k)) * dx2bi(j  )
             dqp       = (dlo(i+3,j+1,k) - dlo(i+3,j  ,k)) * dx2bi(j+1)
             dd  (j,4) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )

             dqm       = (eod(i+3,j  ,k) - eod(i+3,j-1,k)) * dx2bi(j  )
             dqp       = (eod(i+3,j+1,k) - eod(i+3,j  ,k)) * dx2bi(j+1)
             deod(j,4) = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )


c

2030       continue
c
c     2.  Choose time averaged, upwinded interface value.
c
c  For the purposes of consistent advection, construct the mass
c  flux across each 1-interface.  The mass flux will be used to create
c  the fluxes of all variables, including the momenta which are updated
c  in MOMX1.
c
             do 2040 j=jbeg-1,jend+1
               xi         = ( v2  (i  ,j  ,k) - vg2(j  ) ) * dt
               q1         = sign ( haf, xi )
               dtwid (j,1)= ( 0.5 + q1 ) * ( dlo(i  ,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * dd   (j-1,1) )
     2                    + ( 0.5 - q1 ) * ( dlo(i  ,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * dd   (j  ,1) )
c
             mflux (j,1) = dtwid (j,1) * ( v2(i  ,j  ,k) - vg2(j) ) * dt

             dtwid (j,1) = mflux (j,1) * atwid (i  ) * g32a (j  )


               etwid (j,1)= ( 0.5 + q1 ) * ( eod(i  ,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * deod (j-1,1) )
     2                    + ( 0.5 - q1 ) * ( eod(i  ,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * deod (j  ,1) )
c
               etwid (j,1)= dtwid (j,1) * etwid (j,1)


c
               xi         = ( v2  (i+1,j  ,k) - vg2(j  ) ) * dt
               q1         = sign ( haf, xi )
               dtwid (j,2)= ( 0.5 + q1 ) * ( dlo(i+1,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * dd   (j-1,2) )
     2                    + ( 0.5 - q1 ) * ( dlo(i+1,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * dd   (j  ,2) )
c
             mflux (j,2) = dtwid (j,2) * ( v2(i+1,j  ,k) - vg2(j) ) * dt

             dtwid (j,2) = mflux (j,2) * atwid (i+1) * g32a (j  )


               etwid (j,2)= ( 0.5 + q1 ) * ( eod(i+1,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * deod (j-1,2) )
     2                    + ( 0.5 - q1 ) * ( eod(i+1,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * deod (j  ,2) )
c
               etwid (j,2)= dtwid (j,2) * etwid (j,2)


c

               xi         = ( v2  (i+2,j  ,k) - vg2(j  ) ) * dt
               q1         = sign ( haf, xi )
               dtwid (j,3)= ( 0.5 + q1 ) * ( dlo(i+2,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * dd   (j-1,3) )
     2                    + ( 0.5 - q1 ) * ( dlo(i+2,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * dd   (j  ,3) )
c
             mflux (j,3) = dtwid (j,3) * ( v2(i+2,j  ,k) - vg2(j) ) * dt

             dtwid (j,3) = mflux (j,3) * atwid (i+2) * g32a (j  )


               etwid (j,3)= ( 0.5 + q1 ) * ( eod(i+2,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * deod (j-1,3) )
     2                    + ( 0.5 - q1 ) * ( eod(i+2,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * deod (j  ,3) )
c
               etwid (j,3)= dtwid (j,3) * etwid (j,3)


c


               xi         = ( v2  (i+3,j  ,k) - vg2(j  ) ) * dt
               q1         = sign ( haf, xi )
               dtwid (j,4)= ( 0.5 + q1 ) * ( dlo(i+3,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * dd   (j-1,4) )
     2                    + ( 0.5 - q1 ) * ( dlo(i+3,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * dd   (j  ,4) )
c
             mflux (j,4) = dtwid (j,4) * ( v2(i+3,j  ,k) - vg2(j) ) * dt

             dtwid (j,4) = mflux (j,4) * atwid (i+3) * g32a (j  )


               etwid (j,4)= ( 0.5 + q1 ) * ( eod(i+3,j-1,k)
     1                    + ( dx2a(j-1) - xi ) * deod (j-1,4) )
     2                    + ( 0.5 - q1 ) * ( eod(i+3,j  ,k)
     3                    - ( dx2a(j  ) + xi ) * deod (j  ,4) )
c
               etwid (j,4)= dtwid (j,4) * etwid (j,4)


c

2040         continue
c
c  Save the mass flux outside (ibeg:iend,jbeg:jend,kbeg:kend)
c  only for zones next to the inner orders.
c
c               if ( (i.eq.is-1 .and. k.ge.kbeg) .or.
c     &              (i.ge.ibeg .and. k.eq.ks-1) .or.
c     &              (i.eq.is-1 .and. k.eq.ks-1) ) then
c
             if (k.eq.ks-1) then
c
               if (jbeg .eq. js) then
                 mflx(i  ,js-1,k) = mflux (js-1,1)
                 mflx(i+1,js-1,k) = mflux (js-1,2)

                 mflx(i+2,js-1,k) = mflux (js-1,3)


                 mflx(i+3,js-1,k) = mflux (js-1,4)

               endif
                 do 2060 j=jbeg,jend
                   mflx(i  ,j,k) = mflux(j   ,1)
                   mflx(i+1,j,k) = mflux(j   ,2)

                   mflx(i+2,j,k) = mflux(j   ,3)


                   mflx(i+3,j,k) = mflux(j   ,4)

2060             continue
                 if (jend .eq. je) then
                   mflx(i  ,je+1,k) = mflux (je+1,1)
                   mflx(i+1,je+1,k) = mflux (je+1,2)

                   mflx(i+2,je+1,k) = mflux (je+1,3)


                   mflx(i+3,je+1,k) = mflux (je+1,4)

                 endif
c
c  k=ks-1
               endif  
c
c  Perform mass density and energy density advection.  Note that
c  the timestep "dt" is hidden the fluxes "dflx" and "eflx".
c
             if (k.ge.kbeg) then
c
               if (jbeg .eq. js) then
                 mflx(i  ,js-1,k) = mflux (js-1,1)
                 mflx(i+1,js-1,k) = mflux (js-1,2)

                 mflx(i+2,js-1,k) = mflux (js-1,3)


                 mflx(i+3,js-1,k) = mflux (js-1,4)

               endif
               do 2080 j=jbeg,jend
               mflx(i  ,j,k)= mflux (j,1)
               den(i  ,j,k) = ( dlo(i  ,j,k) * dvl2a(j)

     1                      - dtwid (j+1,1) + dtwid (j,1) ) * dvl2a i(j)


               e  (i  ,j,k) = ( e  (i  ,j,k) * dvl2a(j)

     1                      - etwid (j+1,1) + etwid (j,1) ) * dvl2a i(j)

c
c Compute e/d for the next substep.
c

               edn(i  ,j,k) =         e(i  ,j,k) / den(i  ,j,k)



c
               mflx(i+1,j,k)= mflux (j,2)
               den(i+1,j,k) = ( dlo(i+1,j,k) * dvl2a(j)

     1                      - dtwid (j+1,2) + dtwid (j,2) ) * dvl2a i(j)


               e  (i+1,j,k) = ( e  (i+1,j,k) * dvl2a(j)

     1                      - etwid (j+1,2) + etwid (j,2) ) * dvl2a i(j)

c
c Compute e/d for the next substep.
c

               edn(i+1,j,k) =         e(i+1,j,k) / den(i+1,j,k)



c

               mflx(i+2,j,k)= mflux (j,3)
               den(i+2,j,k) = ( dlo(i+2,j,k) * dvl2a(j)

     1                      - dtwid (j+1,3) + dtwid (j,3) ) * dvl2a i(j)


               e  (i+2,j,k) = ( e  (i+2,j,k) * dvl2a(j)

     1                      - etwid (j+1,3) + etwid (j,3) ) * dvl2a i(j)

c
c Compute e/d for the next substep.
c

               edn(i+2,j,k) =         e(i+2,j,k) / den(i+2,j,k)



c


               mflx(i+3,j,k)= mflux (j,4)
               den(i+3,j,k) = ( dlo(i+3,j,k) * dvl2a(j)

     1                      - dtwid (j+1,4) + dtwid (j,4) ) * dvl2a i(j)


               e  (i+3,j,k) = ( e  (i+3,j,k) * dvl2a(j)

     1                      - etwid (j+1,4) + etwid (j,4) ) * dvl2a i(j)

c
c Compute e/d for the next substep.
c

               edn(i+3,j,k) =         e(i+3,j,k) / den(i+3,j,k)



c

2080         continue
               if (jend .eq. je) then
                 mflx(i  ,je+1,k) = mflux (je+1,1)
                 mflx(i+1,je+1,k) = mflux (je+1,2)

                 mflx(i+2,je+1,k) = mflux (je+1,3)


                 mflx(i+3,je+1,k) = mflux (je+1,4)
c  jend>=je
               endif
c  k>=kbeg  
             endif  
2090       continue
c  j=js-1 || j>=jbeg
         endif  
2100   continue
c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////                T R A N X 2                \\\\\\\\\\
c
c=======================================================================
c
c

invivotranx2_tranx2__526

Real time: 9.854991e+08 -- Predicted time: 9.945085e+08

Callcount: 210

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
99	### 1	144.382881224299	1.388266e+06	1.292756e+06	6.8
87	### 2	30.0483550458148	2.642629e+07	2.565068e+07	2.9

                












































































c
c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////                 H S M O C                 \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
       subroutine hsmoc ( emf1, emf2, emf3 )

c
c    dac:zeus3d.mocemfs <-------------------------- MoC estimate of emfs
c                                                          october, 1992
c
c    written by: David Clarke
c    modified 1: Byung-Il Jun, July 1994
c                implemented John Hawley and Jim Stone's scheme to
c                fix pt. explosion of magnetic field in passive field.
c                Basically, this scheme mixes emfs computed with simple
c                upwinding(Evans and Hawley) and MoC.
c                The upwinded values are used to compute the wave
c                speeds for the characteristic cones for the MoC part.
c    modified 2: Robert Fiedler, February 1995
c                upgraded to ZEUS-3D version 3.4 -- improved cache
c                utilization and added parallelization directives for 
c                 multiprocessors.
c    modified 3: Mordecai-Mark Mac Low, December 1997 - March 1998
c                rewritten for ZEUS-MP without overlapping.  Calls to 
c                interpolation routines have been inlined.
c    modified 4: PSLi, December 1999
c                minor modications to prevent scratch arrays overwritten.
c
c  PURPOSE:  Uses the Method of Characteristics (MoC, invented by Jim
c  Stone, John Hawley, Chuck Evans, and Michael Norman; see Stone and
c  Norman, ApJS, v80, p791) to evaluate the velocity and magnetic field
c  needed to estimate emfs that are properly upwinded in the character-
c  istic velocities for the set of equations describing transverse
c  Alfven waves.  This is *not* the full  characteristic problem, but
c  a subset which has been found (reference above) to yield good results
c  for the propagation of Alfven waves.  This routine differs from the
c  previous routines MOC1, MOC2, and MOC3 in version 3.1 in that the
c  Lorentz forces are computed *before* the emfs are estimated.  Thus,
c  the emfs now use the velocities which have been updated with all the
c  source terms, including the transverse Lorenz forces.
c
c  The characteristic equations governing the propagation of Alfven
c  waves in the 1-direction are (see ZEUS3D notes "Method of Character-
c  istics"):
c
c  "plus" characteristic (C+):
c
c    ( db1/dt + (v2 - a2) * db1/dx2 + (v3 - a3) * db1/dx3 ) / sqrt(d)
c  + ( dv1/dt + (v2 - a2) * dv1/dx2 + (v3 - a3) * dv1/dx3 )  =  S    (1)
c
c  "minus" characteristic (C-):
c
c    ( db1/dt + (v2 + a2) * db1/dx2 + (v3 + a3) * db1/dx3 ) / sqrt(d)
c  - ( dv1/dt + (v2 + a2) * dv1/dx2 + (v3 + a3) * dv1/dx3 )  = -S    (2)
c
c  where   a2 = b2/sqrt(d) is the Alfven velocity in the 2-direction
c          a3 = b3/sqrt(d) is the Alfven velocity in the 3-direction
c          g1, g2, g3 are the metric factors
c          S = b1 * ( b2/g2 * dg1/dx2 + b3/g3 * dg1/dx3 )
c
c  Equations (1) and (2) can be written in Lagrangian form:
c
c      1    D+/-           D+/-
c   ------- ----(b1)  +/-  ----(v1)  =  +/- S                        (3)
c   sqrt(d)  Dt             Dt
c
c  where the Lagrangian derivatives are given by
c
c  D+/-     d                   d                   d
c  ----  =  --  +  (v2 -/+ a2) ---  +  (v3 -/+ a3) ---               (4)
c   Dt      dt                 dx2                 dx3
c
c  Differencing equations (3) [e.g. D+(b1) = b* - b+; D-(b1) = b* - b-],
c  and then solving for the advanced time values of b* and v*, one gets:
c                             _                                _
c           sqrt (d+ * d-)   |     b+          b-               |
c  b* =  ------------------- |  -------- + --------- + v+ - v-  |    (5)
c        sqrt(d+) + sqrt(d-) |_ sqrt(d+)    sqrt(d-)           _|
c
c                 1
c  v* =  ------------------- [ v+*sqrt(d+) + v-*sqrt(d-) + b+ - b- ]
c        sqrt(d+) + sqrt(d-)                                         (6)
c
c     + S Dt
c
c  where b+(-), and v+(-) are the upwinded values of the magnetic field
c  and velocity interpolated to the time-averaged bases of C+ (C-), and
c  d+(-) are estimates of the density along each characteristic path
c  during the time interval Dt.
c
c  Equations (1) and (2) would suggest that when estimating "emf2" for
c  example, that the interpolated values for "v1" and "b1" be upwinded
c  in both the 2- and 3- components of the characteristic velocity.  It
c  turns out that this is impractical numerically, and so only the
c  "partial" characteristics are tracked.  While estimating "emf2", "v1"
c  and "b1" are upwinded only in the 3-component of the characteristic
c  velocities.  Conversely, while estimating "emf3", "v1" and "b1" are
c  upwinded only in the 2-component of the characteristic velocities.
c  Since updating "b1" requires both "emf2" and "emf3", the evolution of
c  "b1" will ultimately depend upon the full characteristics.  This
c  amounts to nothing more than directionally splitting the full MoC
c  algorithm.  The effects of such a directionally split implementation
c  are not fully known.  What is known is:
c
c  1) A non-directionally split implementation of the MoC algorithm is
c     not possible without either relocating the emfs to the zone
c     corners or the magnetic field components to the zone centres.
c     The former has been tried (change deck mocemf) and was found to
c     generate intolerable diffusion of magnetic field.  In addition,
c     the algorithm is not unconditionally stable.  The latter has not
c     been tried, but is dismissed on the grounds that div(B) will be
c     determined by truncation errors rather than machine round-off
c     errors.
c
c  2) A directionally split algorithm that is not also operator split
c     (ie, performing the Lorentz updates of the velocities separately
c     from the MoC estimation of the emfs) does not allow stable Alfven
c     wave propagation in 2-D.  Operator splitting the MoC algorithm so
c     that the transverse Lorentz forces are computed *before* the
c     magnetic field update does allow Alfven waves to propagate stably
c     in multi-dimensions but appears to introduce more diffusion for
c     sub-Alfvenic flow.  On the other hand, super-Alfvenic flow does
c     *not* appear to be more diffusive in the operator split scheme.
c
c  INPUT VARIABLES:
c
c  OUTPUT VARIABLES:
c    emf1      emf along 1-edge computed using MoC estimates of v2, b2,
c              v3, and b3.
c    emf2      emf along 2-edge computed using MoC estimates of v3, b3,
c              v1, and b1.
c    emf3      emf along 3-edge computed using MoC estimates of v1, b1,
c              v2, and b2.
c
c  LOCAL VARIABLES:
c
c    1-D variables
c    bave      spatially averaged magnetic field at edge
c    srdp      sqrt(density) along the plus  characteristic (C+)
c    srdm      sqrt(density) along the minus characteristic (C-)
c    vchp      characteristic velocity along C+ (v - va)
c    vchm      characteristic velocity along C- (v + va)
c    vpch      velocity interpolated to the time-centred footpoint of C+
c    vmch      velocity interpolated to the time-centred footpoint of C-
c    bpch      B-field  interpolated to the time-centred footpoint of C+
c    bmch      B-field  interpolated to the time-centred footpoint of C-
c    vsnm1     MoC estimate of v[n-1] used to evaluate emf[n], n=1,2,3
c    bsnm1     MoC estimate of b[n-1] used to evaluate emf[n], n=1,2,3
c
c    2-D variables
c    v3intj   upwinded v3 in 2-direction
c    b3intj   upwinded b3 in 2-direction
c    etc..
c
c    3-D variables
c    srd[n]    sqrt of spatially averaged density at [n]-face n=1,2,3
c    vsnp1     MoC estimate of v[n+1] used to evaluate emf[n], n=1,2,3
c    bsnp1     MoC estimate of b[n+1] used to evaluate emf[n], n=1,2,3
c    vsnp1     is reused as the vsnp1*bsnm1 term in emf[n]
c    bsnp1     is reused as the vsnm1*bsnp1 term in emf[n]
c
c  EXTERNALS:
c    BVALEMF1, BVALEMF2, BVALEMF3
c
c I have inlined these M-MML 8.3.98
c    X1ZC1D  , X2ZC1D  , X3ZC1D
c    X1INT1D , X2INT1D , X3INT1D
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj



      integer stat, req


      logical periodic(3)
      logical reorder
      integer myid, myid_w, nprocs, nprocs_w, coords(3)
      integer ierr, nreq, nsub
      integer comm3d
      integer ntiles(3)
      integer n1m, n1p, n2m, n2p, n3m, n3p
      integer i_slice,j_slice,k_slice
      integer ils_slice,jls_slice,kls_slice
      integer ilsm_slice,jlsm_slice,klsm_slice
      integer ibuf_in(nbuff), ibuf_out(nbuff)
      real*8    buf_in(nbuff), buf_out(nbuff)
      common /mpicomi/ myid, myid_w, nprocs, nprocs_w, coords
     &               , comm3d, ntiles
     &               , n1m, n1p, n2m, n2p, n3m, n3p
     &               , i_slice, j_slice, k_slice
     &               , ils_slice, jls_slice, kls_slice
     &               , ilsm_slice, jlsm_slice, klsm_slice
     &               , ibuf_in, ibuf_out
     &               , stat, req, ierr, nreq, nsub
      common /mpicoml/ periodic, reorder
      common /mpicomr/ buf_in, buf_out
c
       integer      i       , j       , k    

       real*8         absb    , sgnp    , sgnm
     1             , q1      , q2      , src
     &             , qv1, qv2, qb1, qb2, q3 ,dqm ,dqp ,xi ,fact 
     &              , dv(ijkn), db(ijkn)
c
       real*8          bave    (ijkn), srdp    (ijkn), srdm    (ijkn)
     1             , srdpi   (ijkn), srdmi   (ijkn), vchp    (ijkn)
     1             , vchm    (ijkn), vtmp    (ijkn), btmp    (ijkn)
     2             , vpch    (ijkn), vmch    (ijkn), bpch    (ijkn)
     3             , bmch    (ijkn), vsnm1   (ijkn), bsnm1   (ijkn)
     4             , vave    (ijkn), aave    (ijkn)
c
       real*8          vfl     (ijkn), vt      (ijkn), bt      (ijkn)
     1             , vint    (ijkn), bint    (ijkn)
c
       real*8          v3intj  (jn,kn),          b3intj(jn,kn)
     1             , v2intk  (jn,kn),          b2intk(jn,kn)
     2             , v1intk  (kn,in),          b1intk(kn,in)
     3             , v3inti  (kn,in),          b3inti(kn,in)
     4             , v2inti  (in,jn),          b2inti(in,jn)
     5             , v1intj  (in,jn),          b1intj(in,jn)
c
       real*8         emf1    (  in,  jn,  kn), emf2    (  in,  jn,  kn)
     1             , emf3    (  in,  jn,  kn)
       real*8         vsnp1   (  in,  jn,  kn), bsnp1   (  in,  jn,  kn)
     1             , srd1    (  in,  jn,  kn), srd2    (  in,  jn,  kn)
     1             , srd3    (  in,  jn,  kn)
c
c
       equivalence   ( bave    , w1da     ), ( srdp    , w1db     )
     1             , ( srdm    , w1dc     ), ( srdpi   , w1dd     )
     1             , ( srdmi   , w1de     ), ( vchp    , w1df     )
     1             , ( vchm    , w1dg     ), ( vpch    , w1dh     )
     1             , ( vmch    , w1di     ), ( bpch    , w1dj     )
     1             , ( bmch    , w1dk     )
     1             , ( vtmp    , w1dl     )
     1             , ( btmp    , w1dm     )
     1             , ( vave    , w1dn     )
     1             , ( aave    , w1do     )
     1             , ( vsnm1   , w1dp     )
     1             , ( bsnm1   , w1dq     )
     1             , ( vt      , w1dq     )
     1             , ( bt      , w1dr     )
     1             , ( vint    , w1ds     )
     1             , ( bint    , w1dt     )
     1             , ( vfl     , w1du     )
c
c there are no 2D scratch arrays like in ZEUS-3D, but these can all still 
c be equivalenced to each other. M-MML 4 Mar 98
       equivalence   ( v3intj, v2intk, v1intk, v3inti, v2inti
     2               , v1intj                          )
     2             , ( b3intj, b2intk, b1intk, b3inti, b2inti
     2               , b1intj                          )
c
c      Careful!  "wa3d" through "wc3d" are equivalenced in CT.
c                wa3d -> emf1    wb3d -> emf2    wc3d -> emf3
c
c      The worker arrays "we3d" and "wf3d" should still contain "srd2"
c  and "srd3" from LORENTZ. The worker array  "wd3d" will contain
c  "srd1", but "wd3d" is needed for "bsnp1" and "term2".  Thus "srd1"
c  will be recomputed once "srd3" is no longer needed.
c
cRAF We have more array space with wg3d, so don't recompute srd1.
cRAF SGIMP does not like equivalenced variables in the same loop nest,
cRAF so eliminate term1 and term2.
c
CPS
       equivalence   ( srd1              , w3di     )
     1             , ( srd2              , w3dj     )
     1             , ( srd3              , w3df     )
     1             , ( bsnp1             , w3dg     )
C
c
c      External statements
c
       external      bvalemf1, bvalemf2, bvalemf3
c
c-----------------------------------------------------------------------
c
c
c-----------------------------------------------------------------------
c---- 1.  emf1 ---------------------------------------------------------
c-----------------------------------------------------------------------
c
c    BEGINNING OF I LOOPS
c
c
c      By following the characteristics of the flow in the 3-direction,
c  determine values for "v2" and "b2" ("vsnp1" and "bsnp1") to be used
c  in evaluating "emf1".
c
c     Compute upwinded b3 and v3 in the 2-direction and use them to
c     compute the wave speeds for the characteristic cones for the MoC.
c
CPS   Initialize vsnp1
       do k=1,kn
          do j=1,jn
             do i=1,in
                vsnp1(i,j,k)=0.
             enddo
          enddo
       enddo
C
       do 99 k=ks,ke+1
         do 9 i=is,ie
           do 7 j=js-2,je+2
             vfl   (j) = 0.5 * (v2(i,j,k) + v2(i,j,k-1)) - vg2(j)
             vt    (j) = v3(i,j,k) - vg3(k)
             bt    (j) = b3(i,j,k)
7          continue
c
c           call x2int1d ( bt, vfl, iordb3, istpb3, k, i
c     1                  , g2b, g2bi, bint )
c           call x2int1d ( vt, vfl, iords3, istps3, k, i
c     1                  , g2b, g2bi, vint )
c       subroutine x2int1d ( q, vp, iorder, isteep, k, i
c     1                   , g2, g2i , qp )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 807 j=js-1,je+1
             dqm      = ( vt(j  ) - vt(j-1) ) * dx2bi(j  )
             dqp      = ( vt(j+1) - vt(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( bt(j  ) - bt(j-1) ) * dx2bi(j  )
             dqp     = ( bt(j+1) - bt(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 807       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2bi(i)
           do 808 j=js,je+1
             qv1    = vt(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vt(j  ) - dx2a(j  ) * dv (j  )
             qb1    = bt(j-1) + dx2a(j-1) * db (j-1)
             qb2    = bt(j  ) - dx2a(j  ) * db (j  )
c
             xi     = vfl(j) * fact
             q3     = sign ( haf, xi )
             vint(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bint(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
 808       continue

           do 8 j=js,je+1
             emf1(i,j,k) = vint(j)
             emf2(i,j,k) = bint(j)
 8        continue
 9      continue
 99    continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  3-direction.
c
       do 50 j=js,je+1
         do 40 i=is,ie
           do 10 k=ks,ke+1
             vave (k) = emf1(i,j,k)
             bave (k) = emf2(i,j,k)
c            vave (k) = 0.5 * ( v3(i,j,k) + v3(i,jm1,k) ) - vg3(k)
c            bave (k) = 0.5 * ( b3(i,j,k) + b3(i,jm1,k) )
             absb     = abs ( bave(k) )
             aave(k)  = 0.5 * absb * ( srd2(i,j,k) + srd2(i,j,k-1) )
     1                             / ( srd2(i,j,k) * srd2(i,j,k-1) )
             sgnp     = sign ( haf, vave(k) - aave(k) )
             sgnm     = sign ( haf, vave(k) + aave(k) )
             srdp (k) = ( 0.5 + sgnp ) * srd2(i,j,k-1)
     1                + ( 0.5 - sgnp ) * srd2(i,j,k  )
             srdm (k) = ( 0.5 + sgnm ) * srd2(i,j,k-1)
     1                + ( 0.5 - sgnm ) * srd2(i,j,k  )
             srdpi(k) = 1.0 / srdp(k)
             srdmi(k) = 1.0 / srdm(k)
             vchp (k) = vave(k) - absb * srdpi(k)
             vchm (k) = vave(k) + absb * srdmi(k)
10         continue
c
c      Interpolate 1-D vectors of "v2" and "b2" in the 3-direction to
c  the footpoints of both characteristics.
c
           do 20 k=ks-2,ke+2
             vtmp(k) = v2(i,j,k) - vg2(j)
             btmp(k) = b2(i,j,k)
20         continue
c          call x3zc1d ( vtmp, vchp, vchm, iords2, istps2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, vpch, vmch )
c          call x3zc1d ( btmp, vchp, vchm, iordb2, istpb2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, bpch, bmch )
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 820 k=ks-1,ke+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 820       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 830 k=ks,ke+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vchp(k) * fact
             q3     = sign ( haf, xi )
             vpch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = vchm(k) * fact
             q3     = sign ( haf, xi )
             vmch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 830       continue
c
c
c      Evaluate "vsnp1" and "bsnp1" by solving the characteristic
c  equations.  There is no source term since the metric factor "g2" has
c  no explicit dependence on x3.
c
           do 30 k=ks,ke+1
             q2           = sign ( one, bave(k) )
             vsnp1(i,j,k) = ( vpch (k) * srdp (k) + vmch (k) * srdm (k)
     1                      + q2 * ( bpch(k) - bmch(k) ) )
     2                    / ( srdp (k) + srdm (k) )
             bsnp1(i,j,k) = ( bpch (k) * srdpi(k) + bmch (k) * srdmi(k)
     1                      + q2 * ( vpch(k) - vmch(k) ) )
     2                    / ( srdpi(k) + srdmi(k) )
             vsnp1(i,j,k) = vsnp1(i,j,k) * bave(k)
             bsnp1(i,j,k) = bsnp1(i,j,k) * vave(k)
30         continue
c
40       continue
c
50     continue
c
c-----------------------------------------------------------------------
c
c      By following the characteristics of the flow in the 2-direction,
c  determine values for "v3" and "b3" ("vsnm1" and "bsnm1") to be used
c  in evaluating "emf1".
c
       src = 0.0
c
c       Compute upwinded b2 and v2 in the 3-direction and use them to
c       compute the wave speeds for the chracteristic cones for the MoC
c
       do 199 j=js,je+1
         do 59 i=is,ie
           do 57 k=ks-2,ke+2
             vfl   (k) = 0.5 * (v3(i,j,k) + v3(i,j-1,k)) - vg3(k)
             vt    (k) = v2(i,j,k) - vg2(j)
             bt    (k) = b2(i,j,k)
57         continue
c           call x3int1d ( bt, vfl, iordb2, istpb2, i, j
c     1                 , g31b, g31bi, g32a, g32ai, bint )
c           call x3int1d ( vt, vfl, iords2, istps2, i, j
c     1                 , g31b, g31bi, g32a, g32ai, vint )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 857 k=ks-1,ke+1
             dqm      = ( vt(k  ) - vt(k-1) ) * dx3bi(k  )
             dqp      = ( vt(k+1) - vt(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(k  ) - bt(k-1) ) * dx3bi(k  )
             dqp      = ( bt(k+1) - bt(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 857       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 858 k=ks,ke+1
             qv1    = vt(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vt(k  ) - dx3a(k  ) * dv (k  )
             qb1    = bt(k-1) + dx3a(k-1) * db (k-1)
             qb2    = bt(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vfl(k) * fact
             q3     = sign ( haf, xi )
             vint(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bint(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 858       continue
c
           do 58 k=ks,ke+1
             emf1(i,j,k) = vint(k)
             emf2(i,j,k) = bint(k)
 58       continue
 59    continue
 199   continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  2-direction.
c
       do 299 k=ks,ke+1
         do 90 i=is,ie
           do 60 j=js,je+1
             vave (j) = emf1(i,j,k)
             bave (j) = emf2(i,j,k)
c            vave (j) = 0.5 * ( v2(i,j,k) + v2(i,j,km1) ) - vg2(j)
c            bave (j) = 0.5 * ( b2(i,j,k) + b2(i,j,km1) )
             absb     = abs ( bave(j) )
             aave (j) = 0.5 * absb * ( srd3(i,j,k) + srd3(i,j-1,k) )
     1                             / ( srd3(i,j,k) * srd3(i,j-1,k) )
             sgnp     = sign ( haf, vave(j) - aave(j) )
             sgnm     = sign ( haf, vave(j) + aave(j) )
             srdp (j) = ( 0.5 + sgnp ) * srd3(i,j-1,k)
     1                + ( 0.5 - sgnp ) * srd3(i,j,  k)
             srdm (j) = ( 0.5 + sgnm ) * srd3(i,j-1,k)
     1                + ( 0.5 - sgnm ) * srd3(i,j,  k)
             srdpi(j) = 1.0 / srdp(j)
             srdmi(j) = 1.0 / srdm(j)
             vchp (j) = vave(j) - absb * srdpi(j)
             vchm (j) = vave(j) + absb * srdmi(j)
60         continue
c
c      Interpolate 1-D vectors of "v3" and "b3" in the 2-direction to
c  the footpoints of both characteristics.
c
           do 70 j=js-2,je+2
             vtmp(j) = v3(i,j,k) - vg3(k)
             btmp(j) = b3(i,j,k)
70         continue
c           call x2zc1d ( vtmp, vchp, vchm, iords3, istps3, k, i
c     1                 , g2b, g2bi, vpch, vmch )
c           call x2zc1d ( btmp, vchp, vchm, iordb3, istpb3, k, i
c     1                 , g2b, g2bi, bpch, bmch )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
           do 870 j=js-1,je+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 870       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2bi(i)
           do 880 j=js,je+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = vchp(j) * fact
             q3     = sign ( haf, xi )
             vpch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = vchm(j) * fact
             q3     = sign ( haf, xi )
             vmch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 880       continue
c
c      Evaluate "vsnm1" and "bsnm1" by solving the characteristic
c  equations.  The source term is non-zero for RTP and ZRP coordinates
c  since dg32/dx2 .ne. 0.  Compute the two terms in "emf1".
c
           q1 = dt * g2bi(i)
           do 80 j=js,je+1
             q2           = sign ( one, bave(j) )

             vsnm1(  j  ) = ( vpch (j) * srdp (j) + vmch (j) * srdm (j)
     1                      + q2 * ( bpch(j) - bmch(j) ) )
     3                    / ( srdp (j) + srdm (j) ) + src
             bsnm1(  j  ) = ( bpch (j) * srdpi(j) + bmch (j) * srdmi(j)
     1                      + q2 * ( vpch(j) - vmch(j) ) )
     3                    / ( srdpi(j) + srdmi(j) )
             vsnm1(  j  ) = vsnm1(j) * bave(j)
             bsnm1(  j  ) = bsnm1(j) * vave(j)
c
             vsnp1(i,j,k) = 0.5*(  vsnp1(i,j,k) + bsnm1( j ) )
             bsnp1(i,j,k) = 0.5*(  vsnm1( j ) + bsnp1(i,j,k) )
 80       continue
 90     continue
 299  continue
c
c     END OF I LOOP
c
100    continue
c
c-----------------------------------------------------------------------
c
c      Set boundary values for "term1" and "term2".
c
C#ifdef MPI_USED
C       nreq = 0
C       nsub = nsub + 1
C#endif 

       call bvalemf1 ( vsnp1, bsnp1 )

c
c      Compute "emf1" for all 1-edges, including the ghost zones.
c
       do 130 k=ks-2,ke+3
         do 120 j=js-2,je+3
           do 110 i=is-2,ie+2
             emf1(i,j,k) = ( vsnp1(i,j,k) - bsnp1(i,j,k) )

     1                   * dx1a (i)

110        continue
120      continue
130    continue
c
c-----------------------------------------------------------------------
c---- 2.  emf2 ---------------------------------------------------------
c-----------------------------------------------------------------------
c
c     BEGINNING OF FIRST J LOOP
c
       do 180 j=js,je
c
c      By following the characteristics of the flow in the 1-direction,
c  determine values for "v3" and "b3" ("vsnp1" and "bsnp1") to be used
c  in evaluating "emf2".
c
         src = 0.0
c
c      Compute upwinded b1 and v1 in the 3-direction and use them to
c      compute the wave speeds for the chracteristic cones for the MoC.
c
         do 139 i=is,ie+1
           do 137 k=ks-2,ke+2
             vfl   (k) = 0.5*(v3(i,j,k) + v3(i-1,j,k)) - vg3(k)
             vt    (k) = v1(i,j,k) - vg1(i)
             bt    (k) = b1(i,j,k)
137        continue
c
c
c           call x3int1d ( bt, vfl, iordb1, istpb1, i, j
c     1                  , g31b, g31bi, g32a, g32ai, bint )
c           call x3int1d ( vt, vfl, iordb1, istpb1, i, j
c     1                  , g31b, g31bi, g32a, g32ai, vint )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 937 k=ks-1,ke+1
             dqm      = ( vt(k  ) - vt(k-1) ) * dx3bi(k  )
             dqp      = ( vt(k+1) - vt(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(k  ) - bt(k-1) ) * dx3bi(k  )
             dqp      = ( bt(k+1) - bt(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 937       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 938 k=ks,ke+1
             qv1    = vt(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vt(k  ) - dx3a(k  ) * dv (k  )
             qb1    = bt(k-1) + dx3a(k-1) * db (k-1)
             qb2    = bt(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vfl(k) * fact
             q3     = sign ( haf, xi )
             vint(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bint(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 938       continue
c
           do 138 k=ks,ke+1
             v1intk(k,i) = vint(k)
             b1intk(k,i) = bint(k)
138        continue
139      continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  1-direction.
c
         do 170 k=ks,ke+1
           do 140 i=is,ie+1
             vave (i) = v1intk(k,i)
             bave (i) = b1intk(k,i)
c            vave (i) = 0.5 * ( v1(i,j,k) + v1(i,j,km1) ) - vg1(i)
c            bave (i) = 0.5 * ( b1(i,j,k) + b1(i,j,km1) )
             absb     = abs ( bave(i) )
             aave (i) = 0.5 * absb * ( srd3(i,j,k) + srd3(i-1,j,k) )
     1                             / ( srd3(i,j,k) * srd3(i-1,j,k) )
             sgnp     = sign ( haf, vave(i) - aave(i) )
             sgnm     = sign ( haf, vave(i) + aave(i) )
             srdp (i) = ( 0.5 + sgnp ) * srd3(i-1,j,k)
     1                + ( 0.5 - sgnp ) * srd3(i  ,j,k)
             srdm (i) = ( 0.5 + sgnm ) * srd3(i-1,j,k)
     1                + ( 0.5 - sgnm ) * srd3(i  ,j,k)
             srdpi(i) = 1.0 / srdp(i)
             srdmi(i) = 1.0 / srdm(i)
             vchp (i) = vave(i) - absb * srdpi(i)
             vchm (i) = vave(i) + absb * srdmi(i)
140        continue
c
c      Interpolate 1-D vectors of "v3" and "b3" in the 1-direction to
c  the footpoints of both characteristics.
c
           do 150 i=is-2,ie+2
             vtmp(i) = v3(i,j,k) - vg3(k)
             btmp(i) = b3(i,j,k)
150        continue
c           call x1zc1d ( vtmp, vchp, vchm, iords3, istps3, j, k
c     1                 , vpch, vmch )
c           call x1zc1d ( btmp, vchp, vchm, iordb3, istpb3, j, k
c     1                 , bpch, bmch )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 950 i=is-1,ie+1
             dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
             dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
             dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 950       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 960 i=is,ie+1
             qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
             qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
             qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c
             xi     = vchp(i) * dt
             q3     = sign ( haf, xi )
             vpch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bpch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
             xi     = vchm(i) * dt
             q3     = sign ( haf, xi )
             vmch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bmch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
 960       continue
c
c      Evaluate "vsnp1" and "bsnp1" by solving the characteristic
c  equations.  The source term is non-zero for RTP coordinates since
c  dg31/dx1 = 1.0.
c
           do 160 i=is,ie+1
             q2           = sign ( one, bave(i) )

             vsnp1(i,j,k) = ( vpch (i) * srdp (i) + vmch (i) * srdm (i)
     1                       + q2 * ( bpch(i) - bmch(i) ) )
     3                      / ( srdp (i) + srdm (i) ) + src
             bsnp1(i,j,k) = ( bpch (i) * srdpi(i) + bmch (i) * srdmi(i)
     1                       + q2 * ( vpch (i) - vmch (i) ) )
     3                      / ( srdpi(i) + srdmi(i) )
             vsnp1(i,j,k) = vsnp1(i,j,k) * bave(i)
             bsnp1(i,j,k) = bsnp1(i,j,k) * vave(i)
160        continue
c
170      continue
c
c        END OF FIRST J LOOP
c
180    continue
c
c-----------------------------------------------------------------------
c
c
c       BEGINNING OF SECOND J LOOP
c
c
       do 230 j=js,je
c
c      By following the characteristics of the flow in the 3-direction,
c  determine values for "v1" and "b1" ("vsnm1" and "bsnm1") to be used
c  in evaluating "emf2".
c
c       Compute upwinded b3 and v3 in the 1-direction and use them to
c       compute the wave speeds for the chracteristic cones for the MoC
c
         do 189 k=ks,ke+1
           do 188 i=is-2,ie+2
             vfl   (i) = 0.5*(v1(i,j,k) + v1(i,j,k-1)) - vg1(i)
             vt    (i) = v3(i,j,k) - vg3(k)
             bt    (i) = b3(i,j,k)
188        continue
c
c           call x1int1d ( bt, vfl, iordb1, istpb1, j, k
c     1                  , bint )
c           call x1int1d ( vt, vfl, iords1, istps1, j, k
c     1                  , vint )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 988 i=is-1,ie+1
             dqm      = ( vt(i  ) - vt(i-1) ) * dx1bi(i  )
             dqp      = ( vt(i+1) - vt(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(i  ) - bt(i-1) ) * dx1bi(i  )
             dqp      = ( bt(i+1) - bt(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 988       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 987 i=is,ie+1
             qv1    = vt(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vt(i  ) - dx1a(i  ) * dv (i  )
             qb1    = bt(i-1) + dx1a(i-1) * db (i-1)
             qb2    = bt(i  ) - dx1a(i  ) * db (i  )
c
             xi     = vfl(i) * dt
             q3     = sign ( haf, xi )
             vint(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bint(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
 987       continue
c
           do 187 i=is,ie+1
             v3inti(k,i) = vint(i)
             b3inti(k,i) = bint(i)
187        continue
189      continue
c
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  3-direction.
c
         do 220 i=is,ie+1
           do 190 k=ks,ke+1
             vave (k) = v3inti(k,i)
             bave (k) = b3inti(k,i)
c            vave (k) = 0.5 * ( v3(i,j,k) + v3(im1,j,k) ) - vg3(k)
c            bave (k) = 0.5 * ( b3(i,j,k) + b3(im1,j,k) )
             absb     = abs ( bave(k) )
             aave (k) = 0.5 * absb * ( srd1(i,j,k) + srd1(i,j,k-1) )
     1                             / ( srd1(i,j,k) * srd1(i,j,k-1) )
             sgnp     = sign ( haf, vave(k) - aave(k) )
             sgnm     = sign ( haf, vave(k) + aave(k) )
             srdp (k) = ( 0.5 + sgnp ) * srd1(i,j,k-1)
     1                + ( 0.5 - sgnp ) * srd1(i,j,k  )
             srdm (k) = ( 0.5 + sgnm ) * srd1(i,j,k-1)
     1                + ( 0.5 - sgnm ) * srd1(i,j,k  )
             srdpi(k) = 1.0 / srdp(k)
             srdmi(k) = 1.0 / srdm(k)
             vchp (k) = vave(k) - absb * srdpi(k)
             vchm (k) = vave(k) + absb * srdmi(k)
190        continue
c
c      Interpolate 1-D vectors of "v1" and "b1" in the 3-direction to
c  the footpoints of both characteristics.
c
           do 200 k=ks-2,ke+2
             vtmp(k) = v1(i,j,k) - vg1(i)
             btmp(k) = b1(i,j,k)
200        continue
c           call x3zc1d ( vtmp, vchp, vchm, iords1, istps1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, vpch, vmch )
c           call x3zc1d ( btmp, vchp, vchm, iordb1, istpb1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, bpch, bmch )
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 1000 k=ks-1,ke+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 1000      continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31ai(i) * g32bi(j)
           do 1010 k=ks,ke+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vchp(k) * fact
             q3     = sign ( haf, xi )
             vpch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = vchm(k) * fact
             q3     = sign ( haf, xi )
             vmch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 1010      continue
c
c      Evaluate "vsnm1" and "bsnm1" by solving the characteristic
c  equations.  There is no source term since the metric factor "g1" has
c  no explicit dependence on x3.  Compute the two terms in "emf2".
c
           do 210 k=ks,ke+1
             q2           = sign ( one, bave(k) )
             vsnm1(    k) = ( vpch (k) * srdp (k) + vmch (k) * srdm (k)
     1                      + q2 * ( bpch(k) - bmch(k) ) )
     2                    / ( srdp (k) + srdm (k) )
             bsnm1(    k) = ( bpch (k) * srdpi(k) + bmch (k) * srdmi(k)
     1                      + q2 * ( vpch(k) - vmch(k) ) )
     2                    / ( srdpi(k) + srdmi(k) )
             vsnm1(    k) = vsnm1(k) * bave(k)
             bsnm1(    k) = bsnm1(k) * vave(k)
c
             vsnp1(i,j,k) = 0.5*(  vsnp1(i,j,k) + bsnm1(k) )
             bsnp1(i,j,k) = 0.5*(  vsnm1(    k) + bsnp1(i,j,k) )
210        continue
220      continue
c
c       END OF SECOND J LOOP
c
230    continue
c
c-----------------------------------------------------------------------
c
c      Set boundary values for "term1" and "term2".
c
C#ifdef MPI_USED
C       nreq = 0
C       nsub = nsub + 1
C#endif 
       call bvalemf2 ( vsnp1, bsnp1 )

c
c      Compute "emf2" for all 2-edges, including the ghost zones.
c
       do 260 k=ks-2,ke+3
         do 250 j=js-2,je+2
           do 240 i=is-2,ie+3
             emf2(i,j,k) = ( vsnp1(i,j,k) - bsnp1(i,j,k) )

     1                   * dx2a (j) * g2a (i)

240        continue
250      continue
260    continue
c
c-----------------------------------------------------------------------
c---- 3.  emf3 ---------------------------------------------------------
c-----------------------------------------------------------------------
c
c      BEGINNING OF K LOOP
c
       do 360 k=ks,ke
c
c      By following the characteristics of the flow in the 2-direction,
c  determine values for "v1" and "b1" ("vsnp1" and "bsnp1") to be used
c  in evaluating "emf3".
c
c      Compute upwinded b2 and v2 in the 1-direction and use them to
c      compute the wave speeds for the chracteristic cones for MoC.
c
         do 269 j=js,je+1
           do 267 i=is-2,ie+2
             vfl   (i) = 0.5 * (v1(i,j,k) + v1(i,j-1,k)) - vg1(i)
             vt    (i) = v2(i,j,k) - vg2(j)
             bt    (i) = b2(i,j,k)
267        continue
c           call x1int1d ( bt, vfl, iordb2, istpb2, j, k
c     1                  , bint )
c           call x1int1d ( vt, vfl, iords2, istps2, j, k
c     1                  , vint )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 1067 i=is-1,ie+1
             dqm      = ( vt(i  ) - vt(i-1) ) * dx1bi(i  )
             dqp      = ( vt(i+1) - vt(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(i  ) - bt(i-1) ) * dx1bi(i  )
             dqp      = ( bt(i+1) - bt(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 1067      continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 1068 i=is,ie+1
             qv1    = vt(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vt(i  ) - dx1a(i  ) * dv (i  )
             qb1    = bt(i-1) + dx1a(i-1) * db (i-1)
             qb2    = bt(i  ) - dx1a(i  ) * db (i  )
c
             xi     = vfl(i) * dt
             q3     = sign ( haf, xi )
             vint(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bint(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
 1068      continue
c
           do 268 i=is,ie+1
             v2inti(i,j) = vint(i)
             b2inti(i,j) = bint(i)
268        continue
269      continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  2-direction.
c
         do 300 i=is,ie+1
           do 270 j=js,je+1
             vave (j) = v2inti(i,j)
             bave (j) = b2inti(i,j)
c            vave (j) = 0.5 * ( v2(i,j,k) + v2(im1,j,k) ) - vg2(j)
c            bave (j) = 0.5 * ( b2(i,j,k) + b2(im1,j,k) )
             absb     = abs ( bave(j) )
             aave (j) = 0.5 * absb * ( srd1(i,j,k) + srd1(i,j-1,k) )
     1                             / ( srd1(i,j,k) * srd1(i,j-1,k) )
             sgnp     = sign ( haf, vave(j) - aave(j) )
             sgnm     = sign ( haf, vave(j) + aave(j) )
             srdp (j) = ( 0.5 + sgnp ) * srd1(i,j-1,k)
     1                + ( 0.5 - sgnp ) * srd1(i,j  ,k)
             srdm (j) = ( 0.5 + sgnm ) * srd1(i,j-1,k)
     1                + ( 0.5 - sgnm ) * srd1(i,j  ,k)
             srdpi(j) = 1.0 / srdp(j)
             srdmi(j) = 1.0 / srdm(j)
             vchp (j) = vave(j) - absb * srdpi(j)
             vchm (j) = vave(j) + absb * srdmi(j)
270        continue
c
c      Interpolate 1-D vectors of "v1" and "b1" in the 2-direction to
c  the footpoints of both characteristics.
c
           do 280 j=js-2,je+2
             vtmp(j) = v1(i,j,k) - vg1(i)
             btmp(j) = b1(i,j,k)
280        continue
c           call x2zc1d ( vtmp, vchp, vchm, iords1, istps1, k, i
c     1                 , g2a, g2ai, vpch, vmch )
c           call x2zc1d ( btmp, vchp, vchm, iordb1, istpb1, k, i
c     1                 , g2a, g2ai, bpch, bmch )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
           do 1080 j=js-1,je+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 1080      continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2ai(i)
           do 1090 j=js,je+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = vchp(j) * fact
             q3     = sign ( haf, xi )
             vpch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = vchm(j) * fact
             q3     = sign ( haf, xi )
             vmch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 1090      continue
c
c      Evaluate "vsnp1" and "bsnp1" by solving the characteristic
c  equations.  There is no source term since the metric factor "g1" has
c  no explicit dependence on x2.
c
           do 290 j=js,je+1
             q2           = sign ( one, bave(j) )
             vsnp1(i,j,k) = ( vpch (j) * srdp (j) + vmch (j) * srdm (j)
     1                      + q2 * ( bpch(j) - bmch(j) ) )
     2                    / ( srdp (j) + srdm (j) )
             bsnp1(i,j,k) = ( bpch (j) * srdpi(j) + bmch (j) * srdmi(j)
     1                      + q2 * ( vpch(j) - vmch(j) ) )
     2                    / ( srdpi(j) + srdmi(j) )
             vsnp1(i,j,k) = vsnp1(i,j,k) * bave(j)
             bsnp1(i,j,k) = bsnp1(i,j,k) * vave(j)
290        continue
c
300    continue
c
c-----------------------------------------------------------------------
c
c      By following the characteristics of the flow in the 1-direction,
c  determine values for "v2" and "b2" ("vsnm1" and "bsnm1") to be used
c  in evaluating "emf3".
c
       src = 0.0
c
c      Compute upwinded b1 and v1 in the 2-direction and use them to
c      compute the wave speeds for the chracteristic cones for Moc
c
       do 319 i=is,ie+1
         do 317 j=js-2,je+2
           vfl   (j) = 0.5 * (v2(i,j,k) + v2(i-1,j,k)) - vg2(j)
           vt    (j) = v1(i,j,k) - vg1(i)
           bt    (j) = b1(i,j,k)
317      continue
c         call x2int1d ( bt, vfl, iordb1, istpb1, k, i
c     1                , g2b, g2bi, bint )
c         call x2int1d ( vt, vfl, iords1, istps1, k, i
c     1                , g2b, g2bi, vint )
c
         do 1117 j=js-1,je+1
           dqm      = ( vt(j  ) - vt(j-1) ) * dx2bi(j  )
           dqp      = ( vt(j+1) - vt(j  ) ) * dx2bi(j+1)
           dv (j  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )

           dqm     = ( bt(j  ) - bt(j-1) ) * dx2bi(j  )
           dqp     = ( bt(j+1) - bt(j  ) ) * dx2bi(j+1)
           db (j  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )
 1117    continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
         fact = dt * g2bi(i)
         do 1118 j=js,je+1
           qv1    = vt(j-1) + dx2a(j-1) * dv (j-1)
           qv2    = vt(j  ) - dx2a(j  ) * dv (j  )
           qb1    = bt(j-1) + dx2a(j-1) * db (j-1)
           qb2    = bt(j  ) - dx2a(j  ) * db (j  )
c
           xi     = vfl(j) * fact
           q3     = sign ( haf, xi )
           vint(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1            + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
           bint(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1            + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
 1118    continue
c
         do 318 j=js,je+1
           b1intj(i,j) = bint(j)
           v1intj(i,j) = vint(j)
318      continue
319    continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  1-direction.
c
       do 350 j=js,je+1
         do 320 i=is,ie+1
           vave (i) = v1intj(i,j)
           bave (i) = b1intj(i,j)
c          vave (i) = 0.5 * ( v1(i,j,k) + v1(i,jm1,k) ) - vg1(i)
c          bave (i) = 0.5 * ( b1(i,j,k) + b1(i,jm1,k) )
           absb     = abs ( bave(i) )
           aave (i) = 0.5 * absb * ( srd2(i,j,k) + srd2(i-1,j,k) )
     1                           / ( srd2(i,j,k) * srd2(i-1,j,k) )
           sgnp     = sign ( haf, vave(i) - aave(i) )
           sgnm     = sign ( haf, vave(i) + aave(i) )
           srdp (i) = ( 0.5 + sgnp ) * srd2(i-1,j,k)
     1              + ( 0.5 - sgnp ) * srd2(i  ,j,k)
           srdm (i) = ( 0.5 + sgnm ) * srd2(i-1,j,k)
     1              + ( 0.5 - sgnm ) * srd2(i  ,j,k)
           srdpi(i) = 1.0 / srdp(i)
           srdmi(i) = 1.0 / srdm(i)
           vchp (i) = vave(i) - absb * srdpi(i)
           vchm (i) = vave(i) + absb * srdmi(i)
320      continue
c
c      Interpolate 1-D vectors of "v2" and "b2" in the 1-direction to
c  the footpoints of both characteristics.
c
         do 330 i=is-2,ie+2
           vtmp(i) = v2(i,j,k) - vg2(j)
           btmp(i) = b2(i,j,k)
330      continue
c         call x1zc1d ( vtmp, vchp, vchm, iords2, istps2, j, k
c     1               , vpch, vmch )
c         call x1zc1d ( btmp, vchp, vchm, iordb2, istpb2, j, k
c     1               , bpch, bmch )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
         do 1130 i=is-1,ie+1
           dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
           dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
           dv (i  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )
           
           dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
           dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
           db (i  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )
 1130    continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
         do 1140 i=is,ie+1
           qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
           qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
           qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
           qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c          
           xi     = vchp(i) * dt
           q3     = sign ( haf, xi )
           vpch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1            + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
           bpch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1            + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
           xi     = vchm(i) * dt
           q3     = sign ( haf, xi )
           vmch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1            + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
           bmch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1            + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
1140    continue
c
c      Evaluate "vsnm1" and "bsnm1" by solving the characteristic
c  equations.  The source term is non-zero for RTP coordinates since
c  dg2/dx1 = 1.0.  Compute the two terms in "emf3".
c
         do 340 i=is,ie+1
           q2           = sign ( one, bave(i) )

           vsnm1(i    ) = ( vpch (i) * srdp (i) + vmch (i) * srdm (i)
     1                    + q2 * ( bpch(i) - bmch(i) ) )
     3                  / ( srdp (i) + srdm (i) ) + src
           bsnm1(i    ) = ( bpch (i)* srdpi(i) + bmch (i)* srdmi(i)
     1                    + q2 * ( vpch(i) - vmch(i) ) )
     3                  / ( srdpi(i) + srdmi(i) )
c
           vsnm1(i    ) = vsnm1(i) * bave(i)
           bsnm1(i    ) = bsnm1(i) * vave(i)
c
           vsnp1(i,j,k) = 0.5*(  vsnp1(i,j,k) + bsnm1(i) )
           bsnp1(i,j,k) = 0.5*(  vsnm1(i)     + bsnp1(i,j,k) )
340      continue
350    continue
c
c       END OF K LOOP
c
360    continue
c
c-----------------------------------------------------------------------
c
c      Set boundary values for "term1" and "term2".
c
C#ifdef MPI_USED
C       nreq = 0
C       nsub = nsub + 1
C#endif 
       call bvalemf3 ( vsnp1, bsnp1 )

c
c      Compute "emf3" for all 3-edges, including the ghost zones.
c
       do 390 k=ks-2,ke+2
         do 380 j=js-2,je+3
           do 370 i=is-2,ie+3
             emf3(i,j,k) = ( vsnp1(i,j,k) - bsnp1(i,j,k) )

     1                   * dx3a (k) * g31a (i) * g32a (j)

370        continue
380      continue
390    continue

c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////                 H S M O C                 \\\\\\\\\\
c
c=======================================================================

invivohsmoc_hsmoc__1140

Real time: 1.816648e+09 -- Predicted time: 1.798875e+09

Callcount: 30

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
4	### 1	7.02133543368621	6.046898e+07	5.790011e+07	4.2
16	### 2	16.9825720128476	5.951648e+07	6.100050e+07	2.4
27	### 3	6.02346645730695	6.035717e+07	6.339074e+07	4.7

                












































































c
c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////                 H S M O C                 \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
       subroutine hsmoc ( emf1, emf2, emf3 )

c
c    dac:zeus3d.mocemfs <-------------------------- MoC estimate of emfs
c                                                          october, 1992
c
c    written by: David Clarke
c    modified 1: Byung-Il Jun, July 1994
c                implemented John Hawley and Jim Stone's scheme to
c                fix pt. explosion of magnetic field in passive field.
c                Basically, this scheme mixes emfs computed with simple
c                upwinding(Evans and Hawley) and MoC.
c                The upwinded values are used to compute the wave
c                speeds for the characteristic cones for the MoC part.
c    modified 2: Robert Fiedler, February 1995
c                upgraded to ZEUS-3D version 3.4 -- improved cache
c                utilization and added parallelization directives for 
c                 multiprocessors.
c    modified 3: Mordecai-Mark Mac Low, December 1997 - March 1998
c                rewritten for ZEUS-MP without overlapping.  Calls to 
c                interpolation routines have been inlined.
c    modified 4: PSLi, December 1999
c                minor modications to prevent scratch arrays overwritten.
c
c  PURPOSE:  Uses the Method of Characteristics (MoC, invented by Jim
c  Stone, John Hawley, Chuck Evans, and Michael Norman; see Stone and
c  Norman, ApJS, v80, p791) to evaluate the velocity and magnetic field
c  needed to estimate emfs that are properly upwinded in the character-
c  istic velocities for the set of equations describing transverse
c  Alfven waves.  This is *not* the full  characteristic problem, but
c  a subset which has been found (reference above) to yield good results
c  for the propagation of Alfven waves.  This routine differs from the
c  previous routines MOC1, MOC2, and MOC3 in version 3.1 in that the
c  Lorentz forces are computed *before* the emfs are estimated.  Thus,
c  the emfs now use the velocities which have been updated with all the
c  source terms, including the transverse Lorenz forces.
c
c  The characteristic equations governing the propagation of Alfven
c  waves in the 1-direction are (see ZEUS3D notes "Method of Character-
c  istics"):
c
c  "plus" characteristic (C+):
c
c    ( db1/dt + (v2 - a2) * db1/dx2 + (v3 - a3) * db1/dx3 ) / sqrt(d)
c  + ( dv1/dt + (v2 - a2) * dv1/dx2 + (v3 - a3) * dv1/dx3 )  =  S    (1)
c
c  "minus" characteristic (C-):
c
c    ( db1/dt + (v2 + a2) * db1/dx2 + (v3 + a3) * db1/dx3 ) / sqrt(d)
c  - ( dv1/dt + (v2 + a2) * dv1/dx2 + (v3 + a3) * dv1/dx3 )  = -S    (2)
c
c  where   a2 = b2/sqrt(d) is the Alfven velocity in the 2-direction
c          a3 = b3/sqrt(d) is the Alfven velocity in the 3-direction
c          g1, g2, g3 are the metric factors
c          S = b1 * ( b2/g2 * dg1/dx2 + b3/g3 * dg1/dx3 )
c
c  Equations (1) and (2) can be written in Lagrangian form:
c
c      1    D+/-           D+/-
c   ------- ----(b1)  +/-  ----(v1)  =  +/- S                        (3)
c   sqrt(d)  Dt             Dt
c
c  where the Lagrangian derivatives are given by
c
c  D+/-     d                   d                   d
c  ----  =  --  +  (v2 -/+ a2) ---  +  (v3 -/+ a3) ---               (4)
c   Dt      dt                 dx2                 dx3
c
c  Differencing equations (3) [e.g. D+(b1) = b* - b+; D-(b1) = b* - b-],
c  and then solving for the advanced time values of b* and v*, one gets:
c                             _                                _
c           sqrt (d+ * d-)   |     b+          b-               |
c  b* =  ------------------- |  -------- + --------- + v+ - v-  |    (5)
c        sqrt(d+) + sqrt(d-) |_ sqrt(d+)    sqrt(d-)           _|
c
c                 1
c  v* =  ------------------- [ v+*sqrt(d+) + v-*sqrt(d-) + b+ - b- ]
c        sqrt(d+) + sqrt(d-)                                         (6)
c
c     + S Dt
c
c  where b+(-), and v+(-) are the upwinded values of the magnetic field
c  and velocity interpolated to the time-averaged bases of C+ (C-), and
c  d+(-) are estimates of the density along each characteristic path
c  during the time interval Dt.
c
c  Equations (1) and (2) would suggest that when estimating "emf2" for
c  example, that the interpolated values for "v1" and "b1" be upwinded
c  in both the 2- and 3- components of the characteristic velocity.  It
c  turns out that this is impractical numerically, and so only the
c  "partial" characteristics are tracked.  While estimating "emf2", "v1"
c  and "b1" are upwinded only in the 3-component of the characteristic
c  velocities.  Conversely, while estimating "emf3", "v1" and "b1" are
c  upwinded only in the 2-component of the characteristic velocities.
c  Since updating "b1" requires both "emf2" and "emf3", the evolution of
c  "b1" will ultimately depend upon the full characteristics.  This
c  amounts to nothing more than directionally splitting the full MoC
c  algorithm.  The effects of such a directionally split implementation
c  are not fully known.  What is known is:
c
c  1) A non-directionally split implementation of the MoC algorithm is
c     not possible without either relocating the emfs to the zone
c     corners or the magnetic field components to the zone centres.
c     The former has been tried (change deck mocemf) and was found to
c     generate intolerable diffusion of magnetic field.  In addition,
c     the algorithm is not unconditionally stable.  The latter has not
c     been tried, but is dismissed on the grounds that div(B) will be
c     determined by truncation errors rather than machine round-off
c     errors.
c
c  2) A directionally split algorithm that is not also operator split
c     (ie, performing the Lorentz updates of the velocities separately
c     from the MoC estimation of the emfs) does not allow stable Alfven
c     wave propagation in 2-D.  Operator splitting the MoC algorithm so
c     that the transverse Lorentz forces are computed *before* the
c     magnetic field update does allow Alfven waves to propagate stably
c     in multi-dimensions but appears to introduce more diffusion for
c     sub-Alfvenic flow.  On the other hand, super-Alfvenic flow does
c     *not* appear to be more diffusive in the operator split scheme.
c
c  INPUT VARIABLES:
c
c  OUTPUT VARIABLES:
c    emf1      emf along 1-edge computed using MoC estimates of v2, b2,
c              v3, and b3.
c    emf2      emf along 2-edge computed using MoC estimates of v3, b3,
c              v1, and b1.
c    emf3      emf along 3-edge computed using MoC estimates of v1, b1,
c              v2, and b2.
c
c  LOCAL VARIABLES:
c
c    1-D variables
c    bave      spatially averaged magnetic field at edge
c    srdp      sqrt(density) along the plus  characteristic (C+)
c    srdm      sqrt(density) along the minus characteristic (C-)
c    vchp      characteristic velocity along C+ (v - va)
c    vchm      characteristic velocity along C- (v + va)
c    vpch      velocity interpolated to the time-centred footpoint of C+
c    vmch      velocity interpolated to the time-centred footpoint of C-
c    bpch      B-field  interpolated to the time-centred footpoint of C+
c    bmch      B-field  interpolated to the time-centred footpoint of C-
c    vsnm1     MoC estimate of v[n-1] used to evaluate emf[n], n=1,2,3
c    bsnm1     MoC estimate of b[n-1] used to evaluate emf[n], n=1,2,3
c
c    2-D variables
c    v3intj   upwinded v3 in 2-direction
c    b3intj   upwinded b3 in 2-direction
c    etc..
c
c    3-D variables
c    srd[n]    sqrt of spatially averaged density at [n]-face n=1,2,3
c    vsnp1     MoC estimate of v[n+1] used to evaluate emf[n], n=1,2,3
c    bsnp1     MoC estimate of b[n+1] used to evaluate emf[n], n=1,2,3
c    vsnp1     is reused as the vsnp1*bsnm1 term in emf[n]
c    bsnp1     is reused as the vsnm1*bsnp1 term in emf[n]
c
c  EXTERNALS:
c    BVALEMF1, BVALEMF2, BVALEMF3
c
c I have inlined these M-MML 8.3.98
c    X1ZC1D  , X2ZC1D  , X3ZC1D
c    X1INT1D , X2INT1D , X3INT1D
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj



      integer stat, req


      logical periodic(3)
      logical reorder
      integer myid, myid_w, nprocs, nprocs_w, coords(3)
      integer ierr, nreq, nsub
      integer comm3d
      integer ntiles(3)
      integer n1m, n1p, n2m, n2p, n3m, n3p
      integer i_slice,j_slice,k_slice
      integer ils_slice,jls_slice,kls_slice
      integer ilsm_slice,jlsm_slice,klsm_slice
      integer ibuf_in(nbuff), ibuf_out(nbuff)
      real*8    buf_in(nbuff), buf_out(nbuff)
      common /mpicomi/ myid, myid_w, nprocs, nprocs_w, coords
     &               , comm3d, ntiles
     &               , n1m, n1p, n2m, n2p, n3m, n3p
     &               , i_slice, j_slice, k_slice
     &               , ils_slice, jls_slice, kls_slice
     &               , ilsm_slice, jlsm_slice, klsm_slice
     &               , ibuf_in, ibuf_out
     &               , stat, req, ierr, nreq, nsub
      common /mpicoml/ periodic, reorder
      common /mpicomr/ buf_in, buf_out
c
       integer      i       , j       , k    

       real*8         absb    , sgnp    , sgnm
     1             , q1      , q2      , src
     &             , qv1, qv2, qb1, qb2, q3 ,dqm ,dqp ,xi ,fact 
     &              , dv(ijkn), db(ijkn)
c
       real*8          bave    (ijkn), srdp    (ijkn), srdm    (ijkn)
     1             , srdpi   (ijkn), srdmi   (ijkn), vchp    (ijkn)
     1             , vchm    (ijkn), vtmp    (ijkn), btmp    (ijkn)
     2             , vpch    (ijkn), vmch    (ijkn), bpch    (ijkn)
     3             , bmch    (ijkn), vsnm1   (ijkn), bsnm1   (ijkn)
     4             , vave    (ijkn), aave    (ijkn)
c
       real*8          vfl     (ijkn), vt      (ijkn), bt      (ijkn)
     1             , vint    (ijkn), bint    (ijkn)
c
       real*8          v3intj  (jn,kn),          b3intj(jn,kn)
     1             , v2intk  (jn,kn),          b2intk(jn,kn)
     2             , v1intk  (kn,in),          b1intk(kn,in)
     3             , v3inti  (kn,in),          b3inti(kn,in)
     4             , v2inti  (in,jn),          b2inti(in,jn)
     5             , v1intj  (in,jn),          b1intj(in,jn)
c
       real*8         emf1    (  in,  jn,  kn), emf2    (  in,  jn,  kn)
     1             , emf3    (  in,  jn,  kn)
       real*8         vsnp1   (  in,  jn,  kn), bsnp1   (  in,  jn,  kn)
     1             , srd1    (  in,  jn,  kn), srd2    (  in,  jn,  kn)
     1             , srd3    (  in,  jn,  kn)
c
c
       equivalence   ( bave    , w1da     ), ( srdp    , w1db     )
     1             , ( srdm    , w1dc     ), ( srdpi   , w1dd     )
     1             , ( srdmi   , w1de     ), ( vchp    , w1df     )
     1             , ( vchm    , w1dg     ), ( vpch    , w1dh     )
     1             , ( vmch    , w1di     ), ( bpch    , w1dj     )
     1             , ( bmch    , w1dk     )
     1             , ( vtmp    , w1dl     )
     1             , ( btmp    , w1dm     )
     1             , ( vave    , w1dn     )
     1             , ( aave    , w1do     )
     1             , ( vsnm1   , w1dp     )
     1             , ( bsnm1   , w1dq     )
     1             , ( vt      , w1dq     )
     1             , ( bt      , w1dr     )
     1             , ( vint    , w1ds     )
     1             , ( bint    , w1dt     )
     1             , ( vfl     , w1du     )
c
c there are no 2D scratch arrays like in ZEUS-3D, but these can all still 
c be equivalenced to each other. M-MML 4 Mar 98
       equivalence   ( v3intj, v2intk, v1intk, v3inti, v2inti
     2               , v1intj                          )
     2             , ( b3intj, b2intk, b1intk, b3inti, b2inti
     2               , b1intj                          )
c
c      Careful!  "wa3d" through "wc3d" are equivalenced in CT.
c                wa3d -> emf1    wb3d -> emf2    wc3d -> emf3
c
c      The worker arrays "we3d" and "wf3d" should still contain "srd2"
c  and "srd3" from LORENTZ. The worker array  "wd3d" will contain
c  "srd1", but "wd3d" is needed for "bsnp1" and "term2".  Thus "srd1"
c  will be recomputed once "srd3" is no longer needed.
c
cRAF We have more array space with wg3d, so don't recompute srd1.
cRAF SGIMP does not like equivalenced variables in the same loop nest,
cRAF so eliminate term1 and term2.
c
CPS
       equivalence   ( srd1              , w3di     )
     1             , ( srd2              , w3dj     )
     1             , ( srd3              , w3df     )
     1             , ( bsnp1             , w3dg     )
C
c
c      External statements
c
       external      bvalemf1, bvalemf2, bvalemf3
c
c-----------------------------------------------------------------------
c
c
c-----------------------------------------------------------------------
c---- 1.  emf1 ---------------------------------------------------------
c-----------------------------------------------------------------------
c
c    BEGINNING OF I LOOPS
c
c
c      By following the characteristics of the flow in the 3-direction,
c  determine values for "v2" and "b2" ("vsnp1" and "bsnp1") to be used
c  in evaluating "emf1".
c
c     Compute upwinded b3 and v3 in the 2-direction and use them to
c     compute the wave speeds for the characteristic cones for the MoC.
c
CPS   Initialize vsnp1
       do k=1,kn
          do j=1,jn
             do i=1,in
                vsnp1(i,j,k)=0.
             enddo
          enddo
       enddo
C
       do 99 k=ks,ke+1
         do 9 i=is,ie
           do 7 j=js-2,je+2
             vfl   (j) = 0.5 * (v2(i,j,k) + v2(i,j,k-1)) - vg2(j)
             vt    (j) = v3(i,j,k) - vg3(k)
             bt    (j) = b3(i,j,k)
7          continue
c
c           call x2int1d ( bt, vfl, iordb3, istpb3, k, i
c     1                  , g2b, g2bi, bint )
c           call x2int1d ( vt, vfl, iords3, istps3, k, i
c     1                  , g2b, g2bi, vint )
c       subroutine x2int1d ( q, vp, iorder, isteep, k, i
c     1                   , g2, g2i , qp )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 807 j=js-1,je+1
             dqm      = ( vt(j  ) - vt(j-1) ) * dx2bi(j  )
             dqp      = ( vt(j+1) - vt(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( bt(j  ) - bt(j-1) ) * dx2bi(j  )
             dqp     = ( bt(j+1) - bt(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 807       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2bi(i)
           do 808 j=js,je+1
             qv1    = vt(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vt(j  ) - dx2a(j  ) * dv (j  )
             qb1    = bt(j-1) + dx2a(j-1) * db (j-1)
             qb2    = bt(j  ) - dx2a(j  ) * db (j  )
c
             xi     = vfl(j) * fact
             q3     = sign ( haf, xi )
             vint(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bint(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
 808       continue

           do 8 j=js,je+1
             emf1(i,j,k) = vint(j)
             emf2(i,j,k) = bint(j)
 8        continue
 9      continue
 99    continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  3-direction.
c
       do 50 j=js,je+1
         do 40 i=is,ie
           do 10 k=ks,ke+1
             vave (k) = emf1(i,j,k)
             bave (k) = emf2(i,j,k)
c            vave (k) = 0.5 * ( v3(i,j,k) + v3(i,jm1,k) ) - vg3(k)
c            bave (k) = 0.5 * ( b3(i,j,k) + b3(i,jm1,k) )
             absb     = abs ( bave(k) )
             aave(k)  = 0.5 * absb * ( srd2(i,j,k) + srd2(i,j,k-1) )
     1                             / ( srd2(i,j,k) * srd2(i,j,k-1) )
             sgnp     = sign ( haf, vave(k) - aave(k) )
             sgnm     = sign ( haf, vave(k) + aave(k) )
             srdp (k) = ( 0.5 + sgnp ) * srd2(i,j,k-1)
     1                + ( 0.5 - sgnp ) * srd2(i,j,k  )
             srdm (k) = ( 0.5 + sgnm ) * srd2(i,j,k-1)
     1                + ( 0.5 - sgnm ) * srd2(i,j,k  )
             srdpi(k) = 1.0 / srdp(k)
             srdmi(k) = 1.0 / srdm(k)
             vchp (k) = vave(k) - absb * srdpi(k)
             vchm (k) = vave(k) + absb * srdmi(k)
10         continue
c
c      Interpolate 1-D vectors of "v2" and "b2" in the 3-direction to
c  the footpoints of both characteristics.
c
           do 20 k=ks-2,ke+2
             vtmp(k) = v2(i,j,k) - vg2(j)
             btmp(k) = b2(i,j,k)
20         continue
c          call x3zc1d ( vtmp, vchp, vchm, iords2, istps2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, vpch, vmch )
c          call x3zc1d ( btmp, vchp, vchm, iordb2, istpb2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, bpch, bmch )
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 820 k=ks-1,ke+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 820       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 830 k=ks,ke+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vchp(k) * fact
             q3     = sign ( haf, xi )
             vpch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = vchm(k) * fact
             q3     = sign ( haf, xi )
             vmch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 830       continue
c
c
c      Evaluate "vsnp1" and "bsnp1" by solving the characteristic
c  equations.  There is no source term since the metric factor "g2" has
c  no explicit dependence on x3.
c
           do 30 k=ks,ke+1
             q2           = sign ( one, bave(k) )
             vsnp1(i,j,k) = ( vpch (k) * srdp (k) + vmch (k) * srdm (k)
     1                      + q2 * ( bpch(k) - bmch(k) ) )
     2                    / ( srdp (k) + srdm (k) )
             bsnp1(i,j,k) = ( bpch (k) * srdpi(k) + bmch (k) * srdmi(k)
     1                      + q2 * ( vpch(k) - vmch(k) ) )
     2                    / ( srdpi(k) + srdmi(k) )
             vsnp1(i,j,k) = vsnp1(i,j,k) * bave(k)
             bsnp1(i,j,k) = bsnp1(i,j,k) * vave(k)
30         continue
c
40       continue
c
50     continue
c
c-----------------------------------------------------------------------
c
c      By following the characteristics of the flow in the 2-direction,
c  determine values for "v3" and "b3" ("vsnm1" and "bsnm1") to be used
c  in evaluating "emf1".
c
       src = 0.0
c
c       Compute upwinded b2 and v2 in the 3-direction and use them to
c       compute the wave speeds for the chracteristic cones for the MoC
c
       do 199 j=js,je+1
         do 59 i=is,ie
           do 57 k=ks-2,ke+2
             vfl   (k) = 0.5 * (v3(i,j,k) + v3(i,j-1,k)) - vg3(k)
             vt    (k) = v2(i,j,k) - vg2(j)
             bt    (k) = b2(i,j,k)
57         continue
c           call x3int1d ( bt, vfl, iordb2, istpb2, i, j
c     1                 , g31b, g31bi, g32a, g32ai, bint )
c           call x3int1d ( vt, vfl, iords2, istps2, i, j
c     1                 , g31b, g31bi, g32a, g32ai, vint )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 857 k=ks-1,ke+1
             dqm      = ( vt(k  ) - vt(k-1) ) * dx3bi(k  )
             dqp      = ( vt(k+1) - vt(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(k  ) - bt(k-1) ) * dx3bi(k  )
             dqp      = ( bt(k+1) - bt(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 857       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 858 k=ks,ke+1
             qv1    = vt(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vt(k  ) - dx3a(k  ) * dv (k  )
             qb1    = bt(k-1) + dx3a(k-1) * db (k-1)
             qb2    = bt(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vfl(k) * fact
             q3     = sign ( haf, xi )
             vint(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bint(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 858       continue
c
           do 58 k=ks,ke+1
             emf1(i,j,k) = vint(k)
             emf2(i,j,k) = bint(k)
 58       continue
 59    continue
 199   continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  2-direction.
c
       do 299 k=ks,ke+1
         do 90 i=is,ie
           do 60 j=js,je+1
             vave (j) = emf1(i,j,k)
             bave (j) = emf2(i,j,k)
c            vave (j) = 0.5 * ( v2(i,j,k) + v2(i,j,km1) ) - vg2(j)
c            bave (j) = 0.5 * ( b2(i,j,k) + b2(i,j,km1) )
             absb     = abs ( bave(j) )
             aave (j) = 0.5 * absb * ( srd3(i,j,k) + srd3(i,j-1,k) )
     1                             / ( srd3(i,j,k) * srd3(i,j-1,k) )
             sgnp     = sign ( haf, vave(j) - aave(j) )
             sgnm     = sign ( haf, vave(j) + aave(j) )
             srdp (j) = ( 0.5 + sgnp ) * srd3(i,j-1,k)
     1                + ( 0.5 - sgnp ) * srd3(i,j,  k)
             srdm (j) = ( 0.5 + sgnm ) * srd3(i,j-1,k)
     1                + ( 0.5 - sgnm ) * srd3(i,j,  k)
             srdpi(j) = 1.0 / srdp(j)
             srdmi(j) = 1.0 / srdm(j)
             vchp (j) = vave(j) - absb * srdpi(j)
             vchm (j) = vave(j) + absb * srdmi(j)
60         continue
c
c      Interpolate 1-D vectors of "v3" and "b3" in the 2-direction to
c  the footpoints of both characteristics.
c
           do 70 j=js-2,je+2
             vtmp(j) = v3(i,j,k) - vg3(k)
             btmp(j) = b3(i,j,k)
70         continue
c           call x2zc1d ( vtmp, vchp, vchm, iords3, istps3, k, i
c     1                 , g2b, g2bi, vpch, vmch )
c           call x2zc1d ( btmp, vchp, vchm, iordb3, istpb3, k, i
c     1                 , g2b, g2bi, bpch, bmch )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
           do 870 j=js-1,je+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 870       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2bi(i)
           do 880 j=js,je+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = vchp(j) * fact
             q3     = sign ( haf, xi )
             vpch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = vchm(j) * fact
             q3     = sign ( haf, xi )
             vmch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 880       continue
c
c      Evaluate "vsnm1" and "bsnm1" by solving the characteristic
c  equations.  The source term is non-zero for RTP and ZRP coordinates
c  since dg32/dx2 .ne. 0.  Compute the two terms in "emf1".
c
           q1 = dt * g2bi(i)
           do 80 j=js,je+1
             q2           = sign ( one, bave(j) )

             vsnm1(  j  ) = ( vpch (j) * srdp (j) + vmch (j) * srdm (j)
     1                      + q2 * ( bpch(j) - bmch(j) ) )
     3                    / ( srdp (j) + srdm (j) ) + src
             bsnm1(  j  ) = ( bpch (j) * srdpi(j) + bmch (j) * srdmi(j)
     1                      + q2 * ( vpch(j) - vmch(j) ) )
     3                    / ( srdpi(j) + srdmi(j) )
             vsnm1(  j  ) = vsnm1(j) * bave(j)
             bsnm1(  j  ) = bsnm1(j) * vave(j)
c
             vsnp1(i,j,k) = 0.5*(  vsnp1(i,j,k) + bsnm1( j ) )
             bsnp1(i,j,k) = 0.5*(  vsnm1( j ) + bsnp1(i,j,k) )
 80       continue
 90     continue
 299  continue
c
c     END OF I LOOP
c
100    continue
c
c-----------------------------------------------------------------------
c
c      Set boundary values for "term1" and "term2".
c
C#ifdef MPI_USED
C       nreq = 0
C       nsub = nsub + 1
C#endif 

       call bvalemf1 ( vsnp1, bsnp1 )

c
c      Compute "emf1" for all 1-edges, including the ghost zones.
c
       do 130 k=ks-2,ke+3
         do 120 j=js-2,je+3
           do 110 i=is-2,ie+2
             emf1(i,j,k) = ( vsnp1(i,j,k) - bsnp1(i,j,k) )

     1                   * dx1a (i)

110        continue
120      continue
130    continue
c
c-----------------------------------------------------------------------
c---- 2.  emf2 ---------------------------------------------------------
c-----------------------------------------------------------------------
c
c     BEGINNING OF FIRST J LOOP
c
       do 180 j=js,je
c
c      By following the characteristics of the flow in the 1-direction,
c  determine values for "v3" and "b3" ("vsnp1" and "bsnp1") to be used
c  in evaluating "emf2".
c
         src = 0.0
c
c      Compute upwinded b1 and v1 in the 3-direction and use them to
c      compute the wave speeds for the chracteristic cones for the MoC.
c
         do 139 i=is,ie+1
           do 137 k=ks-2,ke+2
             vfl   (k) = 0.5*(v3(i,j,k) + v3(i-1,j,k)) - vg3(k)
             vt    (k) = v1(i,j,k) - vg1(i)
             bt    (k) = b1(i,j,k)
137        continue
c
c
c           call x3int1d ( bt, vfl, iordb1, istpb1, i, j
c     1                  , g31b, g31bi, g32a, g32ai, bint )
c           call x3int1d ( vt, vfl, iordb1, istpb1, i, j
c     1                  , g31b, g31bi, g32a, g32ai, vint )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 937 k=ks-1,ke+1
             dqm      = ( vt(k  ) - vt(k-1) ) * dx3bi(k  )
             dqp      = ( vt(k+1) - vt(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(k  ) - bt(k-1) ) * dx3bi(k  )
             dqp      = ( bt(k+1) - bt(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 937       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 938 k=ks,ke+1
             qv1    = vt(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vt(k  ) - dx3a(k  ) * dv (k  )
             qb1    = bt(k-1) + dx3a(k-1) * db (k-1)
             qb2    = bt(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vfl(k) * fact
             q3     = sign ( haf, xi )
             vint(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bint(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 938       continue
c
           do 138 k=ks,ke+1
             v1intk(k,i) = vint(k)
             b1intk(k,i) = bint(k)
138        continue
139      continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  1-direction.
c
         do 170 k=ks,ke+1
           do 140 i=is,ie+1
             vave (i) = v1intk(k,i)
             bave (i) = b1intk(k,i)
c            vave (i) = 0.5 * ( v1(i,j,k) + v1(i,j,km1) ) - vg1(i)
c            bave (i) = 0.5 * ( b1(i,j,k) + b1(i,j,km1) )
             absb     = abs ( bave(i) )
             aave (i) = 0.5 * absb * ( srd3(i,j,k) + srd3(i-1,j,k) )
     1                             / ( srd3(i,j,k) * srd3(i-1,j,k) )
             sgnp     = sign ( haf, vave(i) - aave(i) )
             sgnm     = sign ( haf, vave(i) + aave(i) )
             srdp (i) = ( 0.5 + sgnp ) * srd3(i-1,j,k)
     1                + ( 0.5 - sgnp ) * srd3(i  ,j,k)
             srdm (i) = ( 0.5 + sgnm ) * srd3(i-1,j,k)
     1                + ( 0.5 - sgnm ) * srd3(i  ,j,k)
             srdpi(i) = 1.0 / srdp(i)
             srdmi(i) = 1.0 / srdm(i)
             vchp (i) = vave(i) - absb * srdpi(i)
             vchm (i) = vave(i) + absb * srdmi(i)
140        continue
c
c      Interpolate 1-D vectors of "v3" and "b3" in the 1-direction to
c  the footpoints of both characteristics.
c
           do 150 i=is-2,ie+2
             vtmp(i) = v3(i,j,k) - vg3(k)
             btmp(i) = b3(i,j,k)
150        continue
c           call x1zc1d ( vtmp, vchp, vchm, iords3, istps3, j, k
c     1                 , vpch, vmch )
c           call x1zc1d ( btmp, vchp, vchm, iordb3, istpb3, j, k
c     1                 , bpch, bmch )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 950 i=is-1,ie+1
             dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
             dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
             dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 950       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 960 i=is,ie+1
             qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
             qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
             qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c
             xi     = vchp(i) * dt
             q3     = sign ( haf, xi )
             vpch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bpch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
             xi     = vchm(i) * dt
             q3     = sign ( haf, xi )
             vmch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bmch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
 960       continue
c
c      Evaluate "vsnp1" and "bsnp1" by solving the characteristic
c  equations.  The source term is non-zero for RTP coordinates since
c  dg31/dx1 = 1.0.
c
           do 160 i=is,ie+1
             q2           = sign ( one, bave(i) )

             vsnp1(i,j,k) = ( vpch (i) * srdp (i) + vmch (i) * srdm (i)
     1                       + q2 * ( bpch(i) - bmch(i) ) )
     3                      / ( srdp (i) + srdm (i) ) + src
             bsnp1(i,j,k) = ( bpch (i) * srdpi(i) + bmch (i) * srdmi(i)
     1                       + q2 * ( vpch (i) - vmch (i) ) )
     3                      / ( srdpi(i) + srdmi(i) )
             vsnp1(i,j,k) = vsnp1(i,j,k) * bave(i)
             bsnp1(i,j,k) = bsnp1(i,j,k) * vave(i)
160        continue
c
170      continue
c
c        END OF FIRST J LOOP
c
180    continue
c
c-----------------------------------------------------------------------
c
c
c       BEGINNING OF SECOND J LOOP
c
c
       do 230 j=js,je
c
c      By following the characteristics of the flow in the 3-direction,
c  determine values for "v1" and "b1" ("vsnm1" and "bsnm1") to be used
c  in evaluating "emf2".
c
c       Compute upwinded b3 and v3 in the 1-direction and use them to
c       compute the wave speeds for the chracteristic cones for the MoC
c
         do 189 k=ks,ke+1
           do 188 i=is-2,ie+2
             vfl   (i) = 0.5*(v1(i,j,k) + v1(i,j,k-1)) - vg1(i)
             vt    (i) = v3(i,j,k) - vg3(k)
             bt    (i) = b3(i,j,k)
188        continue
c
c           call x1int1d ( bt, vfl, iordb1, istpb1, j, k
c     1                  , bint )
c           call x1int1d ( vt, vfl, iords1, istps1, j, k
c     1                  , vint )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 988 i=is-1,ie+1
             dqm      = ( vt(i  ) - vt(i-1) ) * dx1bi(i  )
             dqp      = ( vt(i+1) - vt(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(i  ) - bt(i-1) ) * dx1bi(i  )
             dqp      = ( bt(i+1) - bt(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 988       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 987 i=is,ie+1
             qv1    = vt(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vt(i  ) - dx1a(i  ) * dv (i  )
             qb1    = bt(i-1) + dx1a(i-1) * db (i-1)
             qb2    = bt(i  ) - dx1a(i  ) * db (i  )
c
             xi     = vfl(i) * dt
             q3     = sign ( haf, xi )
             vint(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bint(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
 987       continue
c
           do 187 i=is,ie+1
             v3inti(k,i) = vint(i)
             b3inti(k,i) = bint(i)
187        continue
189      continue
c
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  3-direction.
c
         do 220 i=is,ie+1
           do 190 k=ks,ke+1
             vave (k) = v3inti(k,i)
             bave (k) = b3inti(k,i)
c            vave (k) = 0.5 * ( v3(i,j,k) + v3(im1,j,k) ) - vg3(k)
c            bave (k) = 0.5 * ( b3(i,j,k) + b3(im1,j,k) )
             absb     = abs ( bave(k) )
             aave (k) = 0.5 * absb * ( srd1(i,j,k) + srd1(i,j,k-1) )
     1                             / ( srd1(i,j,k) * srd1(i,j,k-1) )
             sgnp     = sign ( haf, vave(k) - aave(k) )
             sgnm     = sign ( haf, vave(k) + aave(k) )
             srdp (k) = ( 0.5 + sgnp ) * srd1(i,j,k-1)
     1                + ( 0.5 - sgnp ) * srd1(i,j,k  )
             srdm (k) = ( 0.5 + sgnm ) * srd1(i,j,k-1)
     1                + ( 0.5 - sgnm ) * srd1(i,j,k  )
             srdpi(k) = 1.0 / srdp(k)
             srdmi(k) = 1.0 / srdm(k)
             vchp (k) = vave(k) - absb * srdpi(k)
             vchm (k) = vave(k) + absb * srdmi(k)
190        continue
c
c      Interpolate 1-D vectors of "v1" and "b1" in the 3-direction to
c  the footpoints of both characteristics.
c
           do 200 k=ks-2,ke+2
             vtmp(k) = v1(i,j,k) - vg1(i)
             btmp(k) = b1(i,j,k)
200        continue
c           call x3zc1d ( vtmp, vchp, vchm, iords1, istps1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, vpch, vmch )
c           call x3zc1d ( btmp, vchp, vchm, iordb1, istpb1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, bpch, bmch )
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 1000 k=ks-1,ke+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 1000      continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31ai(i) * g32bi(j)
           do 1010 k=ks,ke+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = vchp(k) * fact
             q3     = sign ( haf, xi )
             vpch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = vchm(k) * fact
             q3     = sign ( haf, xi )
             vmch(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmch(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
 1010      continue
c
c      Evaluate "vsnm1" and "bsnm1" by solving the characteristic
c  equations.  There is no source term since the metric factor "g1" has
c  no explicit dependence on x3.  Compute the two terms in "emf2".
c
           do 210 k=ks,ke+1
             q2           = sign ( one, bave(k) )
             vsnm1(    k) = ( vpch (k) * srdp (k) + vmch (k) * srdm (k)
     1                      + q2 * ( bpch(k) - bmch(k) ) )
     2                    / ( srdp (k) + srdm (k) )
             bsnm1(    k) = ( bpch (k) * srdpi(k) + bmch (k) * srdmi(k)
     1                      + q2 * ( vpch(k) - vmch(k) ) )
     2                    / ( srdpi(k) + srdmi(k) )
             vsnm1(    k) = vsnm1(k) * bave(k)
             bsnm1(    k) = bsnm1(k) * vave(k)
c
             vsnp1(i,j,k) = 0.5*(  vsnp1(i,j,k) + bsnm1(k) )
             bsnp1(i,j,k) = 0.5*(  vsnm1(    k) + bsnp1(i,j,k) )
210        continue
220      continue
c
c       END OF SECOND J LOOP
c
230    continue
c
c-----------------------------------------------------------------------
c
c      Set boundary values for "term1" and "term2".
c
C#ifdef MPI_USED
C       nreq = 0
C       nsub = nsub + 1
C#endif 
       call bvalemf2 ( vsnp1, bsnp1 )

c
c      Compute "emf2" for all 2-edges, including the ghost zones.
c
       do 260 k=ks-2,ke+3
         do 250 j=js-2,je+2
           do 240 i=is-2,ie+3
             emf2(i,j,k) = ( vsnp1(i,j,k) - bsnp1(i,j,k) )

     1                   * dx2a (j) * g2a (i)

240        continue
250      continue
260    continue
c
c-----------------------------------------------------------------------
c---- 3.  emf3 ---------------------------------------------------------
c-----------------------------------------------------------------------
c
c      BEGINNING OF K LOOP
c
       do 360 k=ks,ke
c
c      By following the characteristics of the flow in the 2-direction,
c  determine values for "v1" and "b1" ("vsnp1" and "bsnp1") to be used
c  in evaluating "emf3".
c
c      Compute upwinded b2 and v2 in the 1-direction and use them to
c      compute the wave speeds for the chracteristic cones for MoC.
c
         do 269 j=js,je+1
           do 267 i=is-2,ie+2
             vfl   (i) = 0.5 * (v1(i,j,k) + v1(i,j-1,k)) - vg1(i)
             vt    (i) = v2(i,j,k) - vg2(j)
             bt    (i) = b2(i,j,k)
267        continue
c           call x1int1d ( bt, vfl, iordb2, istpb2, j, k
c     1                  , bint )
c           call x1int1d ( vt, vfl, iords2, istps2, j, k
c     1                  , vint )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 1067 i=is-1,ie+1
             dqm      = ( vt(i  ) - vt(i-1) ) * dx1bi(i  )
             dqp      = ( vt(i+1) - vt(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( bt(i  ) - bt(i-1) ) * dx1bi(i  )
             dqp      = ( bt(i+1) - bt(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 1067      continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 1068 i=is,ie+1
             qv1    = vt(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vt(i  ) - dx1a(i  ) * dv (i  )
             qb1    = bt(i-1) + dx1a(i-1) * db (i-1)
             qb2    = bt(i  ) - dx1a(i  ) * db (i  )
c
             xi     = vfl(i) * dt
             q3     = sign ( haf, xi )
             vint(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bint(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
 1068      continue
c
           do 268 i=is,ie+1
             v2inti(i,j) = vint(i)
             b2inti(i,j) = bint(i)
268        continue
269      continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  2-direction.
c
         do 300 i=is,ie+1
           do 270 j=js,je+1
             vave (j) = v2inti(i,j)
             bave (j) = b2inti(i,j)
c            vave (j) = 0.5 * ( v2(i,j,k) + v2(im1,j,k) ) - vg2(j)
c            bave (j) = 0.5 * ( b2(i,j,k) + b2(im1,j,k) )
             absb     = abs ( bave(j) )
             aave (j) = 0.5 * absb * ( srd1(i,j,k) + srd1(i,j-1,k) )
     1                             / ( srd1(i,j,k) * srd1(i,j-1,k) )
             sgnp     = sign ( haf, vave(j) - aave(j) )
             sgnm     = sign ( haf, vave(j) + aave(j) )
             srdp (j) = ( 0.5 + sgnp ) * srd1(i,j-1,k)
     1                + ( 0.5 - sgnp ) * srd1(i,j  ,k)
             srdm (j) = ( 0.5 + sgnm ) * srd1(i,j-1,k)
     1                + ( 0.5 - sgnm ) * srd1(i,j  ,k)
             srdpi(j) = 1.0 / srdp(j)
             srdmi(j) = 1.0 / srdm(j)
             vchp (j) = vave(j) - absb * srdpi(j)
             vchm (j) = vave(j) + absb * srdmi(j)
270        continue
c
c      Interpolate 1-D vectors of "v1" and "b1" in the 2-direction to
c  the footpoints of both characteristics.
c
           do 280 j=js-2,je+2
             vtmp(j) = v1(i,j,k) - vg1(i)
             btmp(j) = b1(i,j,k)
280        continue
c           call x2zc1d ( vtmp, vchp, vchm, iords1, istps1, k, i
c     1                 , g2a, g2ai, vpch, vmch )
c           call x2zc1d ( btmp, vchp, vchm, iordb1, istpb1, k, i
c     1                 , g2a, g2ai, bpch, bmch )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
           do 1080 j=js-1,je+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 1080      continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2ai(i)
           do 1090 j=js,je+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = vchp(j) * fact
             q3     = sign ( haf, xi )
             vpch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = vchm(j) * fact
             q3     = sign ( haf, xi )
             vmch(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmch(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 1090      continue
c
c      Evaluate "vsnp1" and "bsnp1" by solving the characteristic
c  equations.  There is no source term since the metric factor "g1" has
c  no explicit dependence on x2.
c
           do 290 j=js,je+1
             q2           = sign ( one, bave(j) )
             vsnp1(i,j,k) = ( vpch (j) * srdp (j) + vmch (j) * srdm (j)
     1                      + q2 * ( bpch(j) - bmch(j) ) )
     2                    / ( srdp (j) + srdm (j) )
             bsnp1(i,j,k) = ( bpch (j) * srdpi(j) + bmch (j) * srdmi(j)
     1                      + q2 * ( vpch(j) - vmch(j) ) )
     2                    / ( srdpi(j) + srdmi(j) )
             vsnp1(i,j,k) = vsnp1(i,j,k) * bave(j)
             bsnp1(i,j,k) = bsnp1(i,j,k) * vave(j)
290        continue
c
300    continue
c
c-----------------------------------------------------------------------
c
c      By following the characteristics of the flow in the 1-direction,
c  determine values for "v2" and "b2" ("vsnm1" and "bsnm1") to be used
c  in evaluating "emf3".
c
       src = 0.0
c
c      Compute upwinded b1 and v1 in the 2-direction and use them to
c      compute the wave speeds for the chracteristic cones for Moc
c
       do 319 i=is,ie+1
         do 317 j=js-2,je+2
           vfl   (j) = 0.5 * (v2(i,j,k) + v2(i-1,j,k)) - vg2(j)
           vt    (j) = v1(i,j,k) - vg1(i)
           bt    (j) = b1(i,j,k)
317      continue
c         call x2int1d ( bt, vfl, iordb1, istpb1, k, i
c     1                , g2b, g2bi, bint )
c         call x2int1d ( vt, vfl, iords1, istps1, k, i
c     1                , g2b, g2bi, vint )
c
         do 1117 j=js-1,je+1
           dqm      = ( vt(j  ) - vt(j-1) ) * dx2bi(j  )
           dqp      = ( vt(j+1) - vt(j  ) ) * dx2bi(j+1)
           dv (j  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )

           dqm     = ( bt(j  ) - bt(j-1) ) * dx2bi(j  )
           dqp     = ( bt(j+1) - bt(j  ) ) * dx2bi(j+1)
           db (j  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )
 1117    continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
         fact = dt * g2bi(i)
         do 1118 j=js,je+1
           qv1    = vt(j-1) + dx2a(j-1) * dv (j-1)
           qv2    = vt(j  ) - dx2a(j  ) * dv (j  )
           qb1    = bt(j-1) + dx2a(j-1) * db (j-1)
           qb2    = bt(j  ) - dx2a(j  ) * db (j  )
c
           xi     = vfl(j) * fact
           q3     = sign ( haf, xi )
           vint(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1            + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
           bint(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1            + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
 1118    continue
c
         do 318 j=js,je+1
           b1intj(i,j) = bint(j)
           v1intj(i,j) = vint(j)
318      continue
319    continue
c
c      Select an effective density and determine the characteristic
c  velocity using upwinded values for each characteristic in the
c  1-direction.
c
       do 350 j=js,je+1
         do 320 i=is,ie+1
           vave (i) = v1intj(i,j)
           bave (i) = b1intj(i,j)
c          vave (i) = 0.5 * ( v1(i,j,k) + v1(i,jm1,k) ) - vg1(i)
c          bave (i) = 0.5 * ( b1(i,j,k) + b1(i,jm1,k) )
           absb     = abs ( bave(i) )
           aave (i) = 0.5 * absb * ( srd2(i,j,k) + srd2(i-1,j,k) )
     1                           / ( srd2(i,j,k) * srd2(i-1,j,k) )
           sgnp     = sign ( haf, vave(i) - aave(i) )
           sgnm     = sign ( haf, vave(i) + aave(i) )
           srdp (i) = ( 0.5 + sgnp ) * srd2(i-1,j,k)
     1              + ( 0.5 - sgnp ) * srd2(i  ,j,k)
           srdm (i) = ( 0.5 + sgnm ) * srd2(i-1,j,k)
     1              + ( 0.5 - sgnm ) * srd2(i  ,j,k)
           srdpi(i) = 1.0 / srdp(i)
           srdmi(i) = 1.0 / srdm(i)
           vchp (i) = vave(i) - absb * srdpi(i)
           vchm (i) = vave(i) + absb * srdmi(i)
320      continue
c
c      Interpolate 1-D vectors of "v2" and "b2" in the 1-direction to
c  the footpoints of both characteristics.
c
         do 330 i=is-2,ie+2
           vtmp(i) = v2(i,j,k) - vg2(j)
           btmp(i) = b2(i,j,k)
330      continue
c         call x1zc1d ( vtmp, vchp, vchm, iords2, istps2, j, k
c     1               , vpch, vmch )
c         call x1zc1d ( btmp, vchp, vchm, iordb2, istpb2, j, k
c     1               , bpch, bmch )
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
         do 1130 i=is-1,ie+1
           dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
           dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
           dv (i  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )
           
           dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
           dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
           db (i  ) = max ( dqm * dqp, zro )
     1              * sign ( one, dqm + dqp )
     2              / max ( abs ( dqm + dqp ), tiny )
 1130    continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
         do 1140 i=is,ie+1
           qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
           qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
           qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
           qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c          
           xi     = vchp(i) * dt
           q3     = sign ( haf, xi )
           vpch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1            + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
           bpch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1            + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
           xi     = vchm(i) * dt
           q3     = sign ( haf, xi )
           vmch(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1            + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
           bmch(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1            + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
1140    continue
c
c      Evaluate "vsnm1" and "bsnm1" by solving the characteristic
c  equations.  The source term is non-zero for RTP coordinates since
c  dg2/dx1 = 1.0.  Compute the two terms in "emf3".
c
         do 340 i=is,ie+1
           q2           = sign ( one, bave(i) )

           vsnm1(i    ) = ( vpch (i) * srdp (i) + vmch (i) * srdm (i)
     1                    + q2 * ( bpch(i) - bmch(i) ) )
     3                  / ( srdp (i) + srdm (i) ) + src
           bsnm1(i    ) = ( bpch (i)* srdpi(i) + bmch (i)* srdmi(i)
     1                    + q2 * ( vpch(i) - vmch(i) ) )
     3                  / ( srdpi(i) + srdmi(i) )
c
           vsnm1(i    ) = vsnm1(i) * bave(i)
           bsnm1(i    ) = bsnm1(i) * vave(i)
c
           vsnp1(i,j,k) = 0.5*(  vsnp1(i,j,k) + bsnm1(i) )
           bsnp1(i,j,k) = 0.5*(  vsnm1(i)     + bsnp1(i,j,k) )
340      continue
350    continue
c
c       END OF K LOOP
c
360    continue
c
c-----------------------------------------------------------------------
c
c      Set boundary values for "term1" and "term2".
c
C#ifdef MPI_USED
C       nreq = 0
C       nsub = nsub + 1
C#endif 
       call bvalemf3 ( vsnp1, bsnp1 )

c
c      Compute "emf3" for all 3-edges, including the ghost zones.
c
       do 390 k=ks-2,ke+2
         do 380 j=js-2,je+3
           do 370 i=is-2,ie+3
             emf3(i,j,k) = ( vsnp1(i,j,k) - bsnp1(i,j,k) )

     1                   * dx3a (k) * g31a (i) * g32a (j)

370        continue
380      continue
390    continue

c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////                 H S M O C                 \\\\\\\\\\
c
c=======================================================================

invivohsmoc_hsmoc__780

Real time: 6.632617e+08 -- Predicted time: 6.707853e+08

Callcount: 30

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
3	### 1	6.05460492672316	2.137400e+07	2.056393e+07	3.7
11	### 2	8.99642477143142	2.255436e+07	2.175190e+07	3.5
18	### 3	10.003394234075	2.289491e+07	2.237324e+07	2.2
28	### 4	4.99969994784189	2.188906e+07	2.307599e+07	5.1

                












































































c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////               L O R E N T Z               \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
c modified for SPEC CPU2006
c       subroutine lorentz (ibeg,iend,jbeg,jend,kbeg,kend
c     &                   ,u1,u2,u3,w1,w2,w3)
       subroutine lorentz (ibeg,iend,jbeg,jend,kbeg,kend
     &                   ,u1,u2,u3)


c
c    dac:zeus3d.lorentz <----- MoC estimate of transverse lorentz forces
c                                                          october, 1992
c
c    written by: David Clarke
c    modified 1: Mordecai-Mark Mac Low, December 1997 - March 1998
c                rewritten for ZEUS-MP 
c
c  PURPOSE:  Uses the Method of Characteristics (MoC) to compute the
c  transverse components of the Lorentz force and then accelerate the
c  velocities accordingly.  After a suggestion by John Hawley, these
c  source terms are computed separately from the MoC estimate of the
c  emfs (MOCEMFS) and before the magnetic field update.  This improves
c  stability of multi-dimensional Alfven waves.
c
c  MOCEMFS solves the induction equation without the use of operator
c  splitting.  Thus, the relevant characteristic velocities are v+/-va
c  and includes the flow velocity v (from the advection term v grad(B))
c  and the alfven velocity va (from the induction term va grad(B)).
c  Conversely, Euler's equation is operator split, and the advection
c  term (v grad(v)) is handled elsewhere (MOMX*).  Thus, the effective
c  characteristic velocities when estimating the transverse Lorentz
c  terms is simply +/-va (from the induction term va grad(v)).
c
c  See comments in MOCEMFS for further ideas regarding the Method of
c  Characteristics.
c
c  INPUT VARIABLES:
c
c    u[1,2,3] = old velocities
c
c  OUTPUT VARIABLES:
c
c    w[1,2,3] = velocities from ibeg to iend, jbeg to jend, kbeg to kend
c
c  LOCAL VARIABLES:
c    srd[n]    sqrt of spatially averaged density at [n]-face n=1,2,3
c    bave      spatially averaged density at edge
c    srdpi     1.0/srd[n] along the plus  alfven characteristic (A+)
c    srdmi     1.0/srd[n] along the minus alfven characteristic (A-)
c    valp      characteristic velocity along A+ (-va)
c    valm      characteristic velocity along A- (+va)
c    vpal      velocity interpolated to the time-centred footpoint of A+
c    vmal      velocity interpolated to the time-centred footpoint of A-
c    bpal      B-field  interpolated to the time-centred footpoint of A+
c    bmal      B-field  interpolated to the time-centred footpoint of A-
c    bstar     MoC estimate of b[n] used to evaluate st[n], n=1,2,3
c    st[n]     Transverse Lorentz force on the [n]-velocity, n=1,2,3
c
c  EXTERNALS:
c    
c   -----> these are now inlined (M-MML): X1ZC1D  , X2ZC1D  , X3ZC1D
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj

c
       integer       i       , j       , k      
       integer       ibeg,iend,jbeg,jend,kbeg,kend
       real*8          u1 (in,jn,kn),u2 (in,jn,kn),u3 (in,jn,kn)
commented out for SPEC CPU2006
c     &              ,w1 (in,jn,kn),w2 (in,jn,kn),w3 (in,jn,kn)

       real*8          absb ,q1, qv1, qv2, qb1, qb2, q3, dqm, dqp
     &              , xi, fact 
     &              , dv(ijkn), db(ijkn)
c
       real*8          bave    (ijkn), srdpi   (ijkn), srdmi   (ijkn)
     1             , valp    (ijkn), valm    (ijkn), vtmp    (ijkn)
     1             , btmp    (ijkn), vpal    (ijkn), vmal    (ijkn)
     1             , bpal    (ijkn), bmal    (ijkn), bstar   (ijkn)
c
       real*8          st1     (  in,  jn,  kn), st2  (  in,  jn,  kn)
     1             , st3     (  in,  jn,  kn), srd1 (  in,  jn,  kn)
     1             , srd2    (  in,  jn,  kn), srd3 (  in,  jn,  kn)
c
       equivalence   ( bave    , w1da     ), ( srdpi   , w1db     )
     1             , ( srdmi   , w1dc     ), ( vtmp    , w1dd     )
     2             , ( vpal    , w1de     ), ( vmal    , w1df     )
     2             , ( valp    , bpal    , w1dg     )
     1             , ( valm    , bmal    , w1dh     )
     8             , ( btmp    , bstar   , w1di     )
     9             , ( db      , w1dj     ),  ( dv     , w1dk     )
c
c      Routine MOCEMFS is expecting to find "srd1", "srd2", and "srd3" 
c  intact in worker arrays "wd3d", "we3d", and "wf3d" respectively.
c  [but MOCEMFS is in ZEUS-3D. does HSMOC also need these? M-MML 9.12.97 
c       so far, yes 4.3.98]
c
CPS: prevent overwritten of momenta.
C       equivalence   ( st1     , w3da     ), ( st2     , w3db     )
C     1             , ( st3     , w3dc     )
       equivalence   ( srd1    , w3di     ), ( srd2    , w3dj     )
     1             , ( srd3    , w3df     )
c
c      External statements
c
c
c
c-----------------------------------------------------------------------
c
c      Compute face-centred averages of density, initialise source terms
c  to zero.
c
       do 3 k=kbeg-1,kend+1
         do 2 j=jbeg-1,jend+1
           do 1 i=ibeg-1,iend+1
             srd1(i,j,k) = sqrt ( 0.5 * ( d (i,j,k) + d (i-1,j,k) ) )
             srd2(i,j,k) = sqrt ( 0.5 * ( d (i,j,k) + d (i,j-1,k) ) )
             srd3(i,j,k) = sqrt ( 0.5 * ( d (i,j,k) + d (i,j,k-1) ) )
             st1 (i,j,k) = 0.0
             st2 (i,j,k) = 0.0
             st3 (i,j,k) = 0.0
1          continue
2        continue
3      continue
c
c-----------------------------------------------------------------------
c---- 1-force ----------------------------------------------------------
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 2-direction, evaluate
c  "bstar" from "b1" to estimate the 2-transverse Lorentz force.
c
       do 50 k=kbeg,kend
         do 45 i=ibeg,iend+1
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 2-direction.
c
           do 10 j=jbeg,jend+1
             bave (j) = 0.5 * ( b2(i,j,k) + b2(i-1,j,k) )
             absb     = abs ( bave(j) )
             srdpi(j) = 1.0 / srd1(i,j  ,k)
             srdmi(j) = 1.0 / srd1(i,j-1,k)
             valp (j) =-absb * srdpi(j)
             valm (j) = absb * srdmi(j)
10         continue
c
c      Interpolate 1-D vectors of "u1" and "b1" in the 2-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 20 j=jbeg-2,jend+2
             vtmp(j) = v1(i,j,k) - vg1(i)
             btmp(j) = b1(i,j,k)
20         continue


c          call x2zc1d ( vtmp, valp, valm, iords1, istps1, k, i
c    1                 , g2a, g2ai, vpal, vmal )
c          call x2zc1d ( btmp, valp, valm, iordb1, istpb1, k, i
c    1                 , g2a, g2ai, bpal, bmal )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
c  Inline interpolation (following tranx*)
c

           do 22 j=jbeg-1,jend+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
22         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2ai(i)
           do 24 j=jbeg,jend+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = valp(j) * fact
             q3     = sign ( haf, xi )
             vpal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = valm(j) * fact
             q3     = sign ( haf, xi )
             vmal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 24       continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 30 j=jbeg,jend+1
             q1       = sign ( one, bave(j) )
             bstar(j) = ( bpal(j) * srdpi(j) + bmal(j) * srdmi(j)
     1                  + q1 * ( vpal(j) - vmal(j) ) )
     2                / ( srdpi(j) + srdmi(j) )
30         continue
c
c      Evaluate transverse Lorentz force.
c
           do 40 j=jbeg,jend
             st1(i,j,k) = ( bave (j+1) + bave (j) ) * g2ai(i)
     4                  * ( bstar(j+1) - bstar(j) ) * dx2ai(j)
40         continue
45       continue
50     continue
c
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 3-direction, evaluate
c  "bstar" from "b1" to estimate the 3-transverse Lorentz force.
c
       do 100 j=jbeg,jend
         do 95 i=ibeg,iend+1
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 3-direction.
c
           do 60 k=kbeg,kend+1
             bave (k) = 0.5 * ( b3(i,j,k) + b3(i-1,j,k) )
             absb     = abs ( bave(k) )
             srdpi(k) = 1.0 / srd1(i,j,k  )
             srdmi(k) = 1.0 / srd1(i,j,k-1)
             valp (k) =-absb * srdpi(k)
             valm (k) = absb * srdmi(k)
60         continue
c
c      Interpolate 1-D vectors of "u1" and "b1" in the 3-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 70 k=kbeg-2,kend+2
             vtmp(k) = v1(i,j,k) - vg1(i)
             btmp(k) = b1(i,j,k)
70         continue

c           call x3zc1d ( vtmp, valp, valm, iords1, istps1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, vpal, vmal )
c           call x3zc1d ( btmp, valp, valm, iordb1, istpb1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, bpal, bmal )
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 72 k=kbeg-1,kend+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
72         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31ai(i) * g32bi(j)
           do 74 k=kbeg,kend+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = valp(k) * fact
             q3     = sign ( haf, xi )
             vpal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = valm(k) * fact
             q3     = sign ( haf, xi )
             vmal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
74         continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 80 k=kbeg,kend+1
             q1       = sign ( one, bave(k) )
             bstar(k) = ( bpal(k) * srdpi(k) + bmal(k) * srdmi(k)
     1                  + q1 * ( vpal(k) - vmal(k) ) )
     2                / ( srdpi(k) + srdmi(k) )
80         continue
c
c      Evaluate transverse Lorentz force.
c
           q1 = g31ai(i) * g32bi(j)
           do 90 k=kbeg,kend
             st1(i,j,k) = st1(i,j,k)
     1                  + ( bave (k+1) + bave (k) ) * q1
     4                  * ( bstar(k+1) - bstar(k) ) * dx3ai(k)
90         continue
95       continue
100      continue
c
110    continue
c
c-----------------------------------------------------------------------
c---- 2-force ----------------------------------------------------------
c-----------------------------------------------------------------------
c

       do 165 j=jbeg,jend+1
c
c      By following the Alfven velocity in the 3-direction, evaluate
c  "bstar" from "b2" to estimate the 3-transverse Lorentz force.
c
         do 160 i=ibeg,iend
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 3-direction.
c
           do 120 k=kbeg,kend+1
             bave (k) = 0.5 * ( b3(i,j,k) + b3(i,j-1,k) )
             absb     = abs ( bave(k) )
             srdpi(k) = 1.0 / srd2(i,j,k  )
             srdmi(k) = 1.0 / srd2(i,j,k-1)
             valp (k) =-absb * srdpi(k)
             valm (k) = absb * srdmi(k)
120        continue
c
c      Interpolate 1-D vectors of "u2" and "b2" in the 3-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 130 k=kbeg-2,kend+2
             vtmp(k) = v2(i,j,k) - vg2(j)
             btmp(k) = b2(i,j,k)
130        continue
c          call x3zc1d ( vtmp, valp, valm, iords2, istps2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, vpal, vmal )
c          call x3zc1d ( btmp, valp, valm, iordb2, istpb2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, bpal, bmal )
c
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 132 k=kbeg-1,kend+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
132         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 134 k=kbeg,kend+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = valp(k) * fact
             q3     = sign ( haf, xi )
             vpal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = valm(k) * fact
             q3     = sign ( haf, xi )
             vmal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
134         continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 140 k=kbeg,kend+1
             q1       = sign ( one, bave(k) )
             bstar(k) = ( bpal(k) * srdpi(k) + bmal(k) * srdmi(k)
     1                  + q1 * ( vpal(k) - vmal(k) ) )
     2                / ( srdpi(k) + srdmi(k) )
140        continue
c
c      Evaluate transverse Lorentz force.
c
           q1 = g31bi(i) * g32ai(j)
           do 150 k=kbeg,kend
             st2(i,j,k) = ( bave (k+1) + bave (k) ) * q1
     4                  * ( bstar(k+1) - bstar(k) ) * dx3ai(k)
150        continue
160      continue
165    continue
c
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 1-direction, evaluate
c  "bstar" from "b2" to estimate the 1-transverse Lorentz force.
c
c *if def,IRIX.and.SGIMP
c C*$*ASSERT CONCURRENT CALL
c *endif IRIX.and.SGIMP
       do 210 k=kbeg,kend
         do 205 j=jbeg,jend+1
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 1-direction.
c
           do 170 i=ibeg,iend+1
             bave (i) = 0.5 * ( b1(i,j,k) + b1(i,j-1,k) )
             absb     = abs ( bave(i) )
             srdpi(i) = 1.0 / srd2(i  ,j,k)
             srdmi(i) = 1.0 / srd2(i-1,j,k)
             valp (i) =-absb * srdpi(i)
             valm (i) = absb * srdmi(i)
170        continue
c
c      Interpolate 1-D vectors of "u2" and "b2" in the 1-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 180 i=ibeg-2,iend+2
             vtmp(i) = v2(i,j,k) - vg2(j)
             btmp(i) = b2(i,j,k)
180        continue
c          call x1zc1d ( vtmp, valp, valm, iords2, istps2, j, k
c    1                 , vpal, vmal )
c          call x1zc1d ( btmp, valp, valm, iordb2, istpb2, j, k
c    1                 , bpal, bmal )
c       subroutine x1zc1d ( q, vp, vm, iorder, isteep, j, k, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 182 i=ibeg-1,iend+1
             dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
             dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
             dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 182       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 184 i=ibeg,iend+1
             qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
             qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
             qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c
             xi     = valp(i) * dt
             q3     = sign ( haf, xi )
             vpal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bpal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
             xi     = valm(i) * dt
             q3     = sign ( haf, xi )
             vmal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bmal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
184        continue

c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 190 i=ibeg,iend+1
             q1       = sign ( one, bave(i) )
             bstar(i) = ( bpal(i) * srdpi(i) + bmal(i) * srdmi(i)
     1                  + q1 * ( vpal(i) - vmal(i) ) ) * g2a(i)
     2                / ( srdpi(i) + srdmi(i) )
190        continue
c
c      Evaluate transverse Lorentz force.  Note that the metric
c  factor "g2a" has been absorbed into "bstar".
c
           do 200 i=ibeg,iend
             st2(i,j,k) = st2(i,j,k)
     2                  + ( bave (i+1) + bave (i) ) * g2bi(i)
     4                  * ( bstar(i+1) - bstar(i) ) * dx1ai(i)
200        continue
205      continue
210    continue
c
220    continue
c
c-----------------------------------------------------------------------
c---- 3-force ----------------------------------------------------------
c-----------------------------------------------------------------------
c
c *if def,IRIX.and.SGIMP
c C*$*ASSERT CONCURRENT CALL
c *endif IRIX.and.SGIMP
       do 330 k=kbeg,kend+1
c
c      By following the Alfven velocity in the 1-direction, evaluate
c  "bstar" from "b3" to estimate the 1-transverse Lorentz force.
c
         do 270 j=jbeg,jend
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 1-direction.
c
           do 230 i=ibeg,iend+1
             bave (i) = 0.5 * ( b1(i,j,k) + b1(i,j,k-1) )
             absb     = abs ( bave(i) )
             srdpi(i) = 1.0 / srd3(i  ,j,k)
             srdmi(i) = 1.0 / srd3(i-1,j,k)
             valp (i) =-absb * srdpi(i)
             valm (i) = absb * srdmi(i)
230        continue
c
c      Interpolate 1-D vectors of "u3" and "b3" in the 1-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 240 i=ibeg-2,iend+2
             vtmp(i) = v3(i,j,k) - vg3(k)
             btmp(i) = b3(i,j,k)
240        continue
c           call x1zc1d ( vtmp, valp, valm, iords3, istps3, j, k
c     1                 , vpal, vmal )
c           call x1zc1d ( btmp, valp, valm, iordb3, istpb3, j, k
c     1                 , bpal, bmal )
c       subroutine x1zc1d ( q, vp, vm, iorder, isteep, j, k, qp, qm )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 242 i=ibeg-1,iend+1
             dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
             dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
             dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 242       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 244 i=ibeg,iend+1
             qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
             qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
             qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c
             xi     = valp(i) * dt
             q3     = sign ( haf, xi )
             vpal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bpal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
             xi     = valm(i) * dt
             q3     = sign ( haf, xi )
             vmal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bmal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
244        continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 250 i=ibeg,iend+1
             q1       = sign ( one, bave(i) )
             bstar(i) = ( bpal(i) * srdpi(i) + bmal(i) * srdmi(i)
     1                  + q1 * ( vpal(i) - vmal(i) ) ) * g31a(i)
     2                / ( srdpi(i) + srdmi(i) )
250        continue
c
c      Evaluate transverse Lorentz force.  Note that the metric
c  factor "g31a" has been absorbed into "bstar".
c
           do 260 i=ibeg,iend
             st3(i,j,k) = ( bave (i+1) + bave (i) ) * g31bi(i)
     4                  * ( bstar(i+1) - bstar(i) ) * dx1ai(i)
260        continue
270      continue
c
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 2-direction, evaluate
c  "bstar" from "b3" to estimate the 2-transverse Lorentz force.
c
         do 320 i=ibeg,iend
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 2-direction.
c
           do 280 j=jbeg,jend+1
             bave (j) = 0.5 * ( b2(i,j,k) + b2(i,j,k-1) )
             absb     = abs ( bave(j) )
             srdpi(j) = 1.0 / srd3(i,j  ,k)
             srdmi(j) = 1.0 / srd3(i,j-1,k)
             valp (j) =-absb * srdpi(j)
             valm (j) = absb * srdmi(j)
280        continue
c
c      Interpolate 1-D vectors of "u3" and "b3" in the 2-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 290 j=jbeg-2,jend+2
             vtmp(j) = v3(i,j,k) - vg3(k)
             btmp(j) = b3(i,j,k)
290        continue
c           call x2zc1d ( vtmp, valp, valm, iords3, istps3, k, i
c     1                 , g2b, g2bi, vpal, vmal )
c           call x2zc1d ( btmp, valp, valm, iordb3, istpb3, k, i
c     1                 , g2b, g2bi, bpal, bmal )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
            do 292 j=jbeg-1,jend+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
292         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2bi(i)
           do 294 j=jbeg,jend+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = valp(j) * fact
             q3     = sign ( haf, xi )
             vpal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = valm(j) * fact
             q3     = sign ( haf, xi )
             vmal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 294       continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 300 j=jbeg,jend+1
             q1       = sign ( one, bave(j) )
             bstar(j) = ( bpal(j) * srdpi(j) + bmal(j) * srdmi(j)
     1                  + q1 * ( vpal(j) - vmal(j) ) ) * g32a(j)
     1                / ( srdpi(j) + srdmi(j) )
300        continue
c
c      Evaluate transverse Lorentz force.  Note that the metric
c  factor "g32a" has been absorbed into "bstar".
c
           do 310 j=jbeg,jend
             st3(i,j,k) = st3(i,j,k)
     2                  + ( bave (j+1) + bave (j) ) * g2ai(i) * g32bi(j)
     4                  * ( bstar(j+1) - bstar(j) ) * dx2ai(j)
310        continue
320      continue
c
330    continue
c
c-----------------------------------------------------------------------
c
c      Accelerate velocities and set boundaries.
c
       q1 = 0.5 * dt

c modified for SPEC CPU2006
c       do 360 k=kbeg,kend
c         do 350 j=jbeg,jend
c           do 340 i=ibeg,iend
c             w1(i,j,k) = u1(i,j,k) + q1 * st1(i,j,k) / srd1(i,j,k)**2
c             w2(i,j,k) = u2(i,j,k) + q1 * st2(i,j,k) / srd2(i,j,k)**2
c             w3(i,j,k) = u3(i,j,k) + q1 * st3(i,j,k) / srd3(i,j,k)**2
c340        continue
c350      continue
c360    continue
       do 360 k=kbeg,kend
         do 350 j=jbeg,jend
           do 340 i=ibeg,iend
             u1(i,j,k) = v1(i,j,k) + q1 * st1(i,j,k) / srd1(i,j,k)**2
             u2(i,j,k) = v2(i,j,k) + q1 * st2(i,j,k) / srd2(i,j,k)**2
             u3(i,j,k) = v3(i,j,k) + q1 * st3(i,j,k) / srd3(i,j,k)**2
340        continue
350      continue
360    continue
c


c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////               L O R E N T Z               \\\\\\\\\\
c
c=======================================================================
c

invivolorentz_lorentz__741

Real time: 7.646798e+08 -- Predicted time: 7.880262e+08

Callcount: 270

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
151	### 1	93.2978906288819	7.058371e+06	7.003604e+06	0.7
69	### 2	170.059736272005	7.614680e+05	6.591640e+05	13.4

                












































































c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////                 M O M X 3                 \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
       subroutine momx3 ( ibeg,iend,jbeg,jend,kbeg,kend
     &                  , s1,s2,s3,mflx )
c
c    dac:zeus3d.momx3 <--------------- transports momenta in 3-direction
c                                                         february, 1990
c
c    written by: David Clarke
c    modified 1: November, 1992 by David Clarke; momenta are now updated
c                between and including i=is,ie, j=js,je, and k=ks,ke to
c                allow for proper treatment of periodic boundaries.
c    modified 2: Feb. 22, 1996 by Robert Fiedler; completely rewritten
c                for ZEUS-MP.
c    modified 3: July 6, 1996 by Robert Fiedler; blocked the k-loop
c                to improve performance on systems with a small 128.
c    modified 4: Aug. 2, 1996 by Robert Fiedler; unrolled the i-loop
c                to improve performance on systems with a small cache.
c
c  PURPOSE:  Transports the three components of the momentum density in
c  the 3-direction using the consistent transport algorithm, including
c  the effects of grid compression.  The transported fluxes are thus
c  given by the mass fluxes times the time centred area of the control
c  volume faces times the interpolated velocities.  Interpolations are
c  performed in-line.
c
c  INPUT VARIABLES:
c    mflx    mass flux in 3-direction
c    s1      momentum density in 1-direction
c    s2      momentum density in 2-direction
c    s3      momentum density in 3-direction
c
c BOUNDARY VALUES USED:
c
c    Macro defined  var   ii    oi    ij    oj    ik    ok
c    -------------  ---  ----  ----  ----  ----  ----  ----
c                  mflx  is-1        js-1        ks-1  ke+1
c                    u1                          ks-2  ke+2
c                    u2                          ks-2  ke+2
c                    u3  is-1        js-1        ks-2  ke+2
c
c  OUTPUT VARIABLES:
c    s1      momentum density in 1-direction updated in the 3-direction
c    s2      momentum density in 2-direction updated in the 3-direction
c    s3      momentum density in 3-direction updated in the 3-direction
c
c  LOCAL VARIABLES:
c
c  EXTERNALS:
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj

c
       integer  i,j,k, ibeg,iend,jbeg,jend,kbeg,kend
c
       real*8  xi, q1, q2, vel, dqm,dqp
c
       real*8        atwid1  (ijkn), atwid2 (ijkn), atwid3 (ijkn)
     &           , atwidj1 (ijkn), atwidj2(ijkn), atwidj3(ijkn)
c

       real*8        sflx  (ijkn,4), dq   (ijkn,4)

       integer  iriter

c
       real*8        mflx    (  in,  jn,  kn), s1      (  in,  jn,  kn)
     1           , s2      (  in,  jn,  kn), s3      (  in,  jn,  kn)
c
       equivalence   ( atwid1  , w1da     ), ( atwidj1 , w1dd     )
     1             , ( atwid2  , w1db     ), ( atwidj2 , w1de     )
     2             , ( atwid3  , w1dc     ), ( atwidj3 , w1df     )
c


c.......................................................................
c
c      Compute time-centred area factors.
c
       do 10 i=ibeg,iend
         atwid1(i) = 0.5 * g2a (i) * dx1b(i) * dvl1bi(i)
         atwid2(i) = 0.5 * g2b (i) * g2b (i) * dx1a  (i) * dvl1ai(i)
         atwid3(i) = 0.5 * g31b(i) * g2b (i) * dx1a  (i) * dvl1ai(i)
10     continue
       do 20 j=jbeg,jend
         atwidj1(j) = dx2a(j) * dvl2ai(j)
         atwidj2(j) = dx2b(j) * dvl2bi(j)
         atwidj3(j) = g32b(j) * dx2a  (j) * dvl2ai(j)
20     continue
c
c.......................................................................
c
       do 3000 j=jbeg,jend

c
c Do the iterations which will not be done in unrolled loops first.
c
         iriter = mod(iend-ibeg+1,4)
         do 2000 i=ibeg,ibeg+iriter-1

c
c------------------------------ TRANSPORT S1 ---------------------------
c
c      Interpolate "v1" at the 3-interfaces.
c
c       call x3zc3d ( v1, vel3, is, js, ie, je, iords1, istps1
c     1             , g31a, g31ai, g32b, g32bi, sflx 3, p      )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 1070 k=kbeg-1,kend+1
             dqm        = (v1 (i  ,j,k  ) - v1 (i  ,j,k-1)) * dx3bi(k  )
             dqp        = (v1 (i  ,j,k+1) - v1 (i  ,j,k  )) * dx3bi(k+1)
             dq(k,1)    = max ( dqm * dqp, zro )
     1                  * sign ( one, dqm + dqp )
     2                  / max ( abs ( dqm + dqp ), tiny )
1070       continue
c
c  2.  Choose time averaged, upwinded interface value.
c
c      Construct an i-average of "v3" to be used for interpolation.
c
c      Construct the 1-momentum flux at the 3-interfaces and perform
c  1-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
           do 1100 k=kbeg,kend+1
             vel         = 0.5 * ( v3(i-1,j,k  ) + v3(i  ,j,k  ) )
              q2         = dt * g31ai(i  ) * g32bi(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,1) = ( 0.5 + q1 ) * ( v1 (i  ,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,1) )
     2                   + ( 0.5 - q1 ) * ( v1 (i  ,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,1) )
              sflx (k,1) = ( mflx (i-1,j,k  ) + mflx (i  ,j,k  ) )
     1                   * sflx (k,1)    * atwid1(i  ) * atwidj1(j)
1100       continue
c
           do 1170 k=kbeg,kend
             s1(i  ,j,k)  = ( s1(i  ,j,k) * dvl3a(k)

     1                    - sflx(k+1,1) + sflx(k,1) ) * dvl3a i(k)

1170       continue
c
c------------------------------ TRANSPORT S2 ---------------------------
c
c      Interpolate "v2" at the 3-interfaces.
c
c       call x3zc3d ( v2, vel3, is, js, ie, je, iords2, istps2
c     1             , g31b, g31bi, g32a, g32ai, sflx 3, p      )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 1270 k=kbeg-1,kend+1
             dqm       = (v2 (i  ,j,k  ) - v2 (i  ,j,k-1)) * dx3bi(k  )
             dqp       = (v2 (i  ,j,k+1) - v2 (i  ,j,k  )) * dx3bi(k+1)
             dq(k,1)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
1270       continue
c
c  2.  Choose time averaged, upwinded interface value.
c
c      Construct a j-average of "v3" to be used for interpolation.
c
c      Construct the 2-momentum flux at the 3-interfaces and perform
c  2-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
           do 1300 k=kbeg,kend+1
             vel         = 0.5 * ( v3(i  ,j-1,k  ) + v3(i  ,j,k  ) )
              q2         = dt * g31bi(i  ) * g32ai(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,1) = ( 0.5 + q1 ) * ( v2 (i  ,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,1) )
     2                   + ( 0.5 - q1 ) * ( v2 (i  ,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,1) )
              sflx (k,1) = ( mflx (i  ,j-1,k  ) + mflx (i  ,j  ,k  ) )
     1                   * sflx (k,1) * atwid2(i  ) * atwidj2(j)
1300       continue
c
           do 1370 k=kbeg,kend
             s2(i  ,j,k) = ( s2(i  ,j,k) * dvl3a(k)

     1                   - sflx(k+1,1) + sflx(k  ,1) ) * dvl3a i(k)

1370       continue
c
c------------------------------ TRANSPORT S3 ---------------------------
c
c
c      Interpolate "v3" at the zone centers.
c
c       call x3fc3d ( v3, vel3, is, js, ie, je, iords3, sflx 3 )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 1470 k=kbeg-1,kend+1
             dqm       = (v3 (i  ,j,k  ) - v3 (i  ,j,k-1)) * dx3ai(k-1)
             dqp       = (v3 (i  ,j,k+1) - v3 (i  ,j,k  )) * dx3ai(k  )
             dq(k,1)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
1470       continue
c
c  2.  Choose time averaged, upwinded interface value.
c
c      Construct a k-average of "v3-vg3" to be used for interpolation.
c
c      Construct the 3-momentum flux at the 3-interfaces and perform
c  3-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
           do 1500 k=kbeg-1,kend
             vel         = 0.5 * ( v3(i  ,j,k  ) - vg3(k  )
     1                           + v3(i  ,j,k+1) - vg3(k+1) )
              xi         = vel         * dt * g31bi(i  ) * g32bi(j)
              q1         = sign ( haf, xi )
              sflx (k,1) = ( 0.5 + q1 ) * ( v3(i  ,j,k  )
     1                   + ( dx3b(k  ) - xi ) * dq(k  ,1) )
     2                   + ( 0.5 - q1 ) * ( v3(i  ,j,k+1)
     3                   - ( dx3b(k+1) + xi ) * dq(k+1,1) )
              sflx (k,1) = ( mflx (i  ,j,k  ) + mflx (i  ,j,k+1) )
     1                   * sflx (k,1) * atwid3(i  ) * atwidj3(j)
1500       continue
c
           do 1570 k=kbeg,kend
             s3(i  ,j,k) = ( s3(i  ,j,k) * dvl3b(k)

     1                   - sflx(k  ,1) + sflx(k-1,1) ) * dvl3b i(k)

1570       continue
2000     continue

c
c Do the bulk of the iterations in unrolled loops.
c
           do 2900 i=ibeg+iriter,iend,4
c
c------------------------------ TRANSPORT S1 ---------------------------
c
c      Interpolate "v1" at the 3-interfaces.
c
c       call x3zc3d ( v1, vel3, is, js, ie, je, iords1, istps1
c     1             , g31a, g31ai, g32b, g32bi, sflx 3, p      )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 2070 k=kbeg-1,kend+1
             dqm        = (v1 (i  ,j,k  ) - v1 (i  ,j,k-1)) * dx3bi(k  )
             dqp        = (v1 (i  ,j,k+1) - v1 (i  ,j,k  )) * dx3bi(k+1)
             dq(k,1)    = max ( dqm * dqp, zro )
     1                  * sign ( one, dqm + dqp )
     2                  / max ( abs ( dqm + dqp ), tiny )
c
             dqm        = (v1 (i+1,j,k  ) - v1 (i+1,j,k-1)) * dx3bi(k  )
             dqp        = (v1 (i+1,j,k+1) - v1 (i+1,j,k  )) * dx3bi(k+1)
             dq(k,2)    = max ( dqm * dqp, zro )
     1                  * sign ( one, dqm + dqp )
     2                  / max ( abs ( dqm + dqp ), tiny )
c

             dqm        = (v1 (i+2,j,k  ) - v1 (i+2,j,k-1)) * dx3bi(k  )
             dqp        = (v1 (i+2,j,k+1) - v1 (i+2,j,k  )) * dx3bi(k+1)
             dq(k,3)    = max ( dqm * dqp, zro )
     1                  * sign ( one, dqm + dqp )
     2                  / max ( abs ( dqm + dqp ), tiny )
c


             dqm        = (v1 (i+3,j,k  ) - v1 (i+3,j,k-1)) * dx3bi(k  )
             dqp        = (v1 (i+3,j,k+1) - v1 (i+3,j,k  )) * dx3bi(k+1)
             dq(k,4)    = max ( dqm * dqp, zro )
     1                  * sign ( one, dqm + dqp )
     2                  / max ( abs ( dqm + dqp ), tiny )
c

2070       continue
c
c  2.  Choose time averaged, upwinded interface value.
c
c      Construct an i-average of "v3" to be used for interpolation.
c
c      Construct the 1-momentum flux at the 3-interfaces and perform
c  1-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
           do 2100 k=kbeg,kend+1
             vel         = 0.5 * ( v3(i-1,j,k  ) + v3(i  ,j,k  ) )
              q2         = dt * g31ai(i  ) * g32bi(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,1) = ( 0.5 + q1 ) * ( v1 (i  ,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,1) )
     2                   + ( 0.5 - q1 ) * ( v1 (i  ,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,1) )
              sflx (k,1) = ( mflx (i-1,j,k  ) + mflx (i  ,j,k  ) )
     1                   * sflx (k,1)    * atwid1(i  ) * atwidj1(j)
c
             vel         = 0.5 * ( v3(i  ,j,k  ) + v3(i+1,j,k  ) )
              q2         = dt * g31ai(i+1) * g32bi(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,2) = ( 0.5 + q1 ) * ( v1 (i+1,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,2) )
     2                   + ( 0.5 - q1 ) * ( v1 (i+1,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,2) )
              sflx (k,2) = ( mflx (i  ,j,k  ) + mflx (i+1,j,k  ) )
     1                   * sflx (k,2)    * atwid1(i+1) * atwidj1(j)
c

             vel         = 0.5 * ( v3(i+1,j,k  ) + v3(i+2,j,k  ) )
              q2         = dt * g31ai(i+2) * g32bi(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,3) = ( 0.5 + q1 ) * ( v1 (i+2,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,3) )
     2                   + ( 0.5 - q1 ) * ( v1 (i+2,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,3) )
              sflx (k,3) = ( mflx (i+1,j,k  ) + mflx (i+2,j,k  ) )
     1                   * sflx (k,3)    * atwid1(i+2) * atwidj1(j)
c


             vel         = 0.5 * ( v3(i+2,j,k  ) + v3(i+3,j,k  ) )
              q2         = dt * g31ai(i+3) * g32bi(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,4) = ( 0.5 + q1 ) * ( v1 (i+3,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,4) )
     2                   + ( 0.5 - q1 ) * ( v1 (i+3,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,4) )
              sflx (k,4) = ( mflx (i+2,j,k  ) + mflx (i+3,j,k  ) )
     1                   * sflx (k,4)    * atwid1(i+3) * atwidj1(j)
c

2100       continue
c
           do 2170 k=kbeg,kend
             s1(i  ,j,k)  = ( s1(i  ,j,k) * dvl3a(k)

     1                    - sflx(k+1,1) + sflx(k,1) ) * dvl3a i(k)

c
             s1(i+1,j,k)  = ( s1(i+1,j,k) * dvl3a(k)

     1                    - sflx(k+1,2) + sflx(k,2) ) * dvl3a i(k)

c

             s1(i+2,j,k)  = ( s1(i+2,j,k) * dvl3a(k)

     1                    - sflx(k+1,3) + sflx(k,3) ) * dvl3a i(k)

c


             s1(i+3,j,k)  = ( s1(i+3,j,k) * dvl3a(k)

     1                    - sflx(k+1,4) + sflx(k,4) ) * dvl3a i(k)

c

2170       continue
c
c------------------------------ TRANSPORT S2 ---------------------------
c
c      Interpolate "v2" at the 3-interfaces.
c
c       call x3zc3d ( v2, vel3, is, js, ie, je, iords2, istps2
c     1             , g31b, g31bi, g32a, g32ai, sflx 3, p      )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 2270 k=kbeg-1,kend+1
             dqm       = (v2 (i  ,j,k  ) - v2 (i  ,j,k-1)) * dx3bi(k  )
             dqp       = (v2 (i  ,j,k+1) - v2 (i  ,j,k  )) * dx3bi(k+1)
             dq(k,1)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c
             dqm       = (v2 (i+1,j,k  ) - v2 (i+1,j,k-1)) * dx3bi(k  )
             dqp       = (v2 (i+1,j,k+1) - v2 (i+1,j,k  )) * dx3bi(k+1)
             dq(k,2)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c

             dqm       = (v2 (i+2,j,k  ) - v2 (i+2,j,k-1)) * dx3bi(k  )
             dqp       = (v2 (i+2,j,k+1) - v2 (i+2,j,k  )) * dx3bi(k+1)
             dq(k,3)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c


             dqm       = (v2 (i+3,j,k  ) - v2 (i+3,j,k-1)) * dx3bi(k  )
             dqp       = (v2 (i+3,j,k+1) - v2 (i+3,j,k  )) * dx3bi(k+1)
             dq(k,4)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c

2270       continue
c
c  2.  Choose time averaged, upwinded interface value.
c
c      Construct a j-average of "v3" to be used for interpolation.
c      Construct the 2-momentum flux at the 3-interfaces and perform
c
c  2-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
           do 2300 k=kbeg,kend+1
             vel         = 0.5 * ( v3(i  ,j-1,k  ) + v3(i  ,j,k  ) )
              q2         = dt * g31bi(i  ) * g32ai(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,1) = ( 0.5 + q1 ) * ( v2 (i  ,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,1) )
     2                   + ( 0.5 - q1 ) * ( v2 (i  ,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,1) )
              sflx (k,1) = ( mflx (i  ,j-1,k  ) + mflx (i  ,j  ,k  ) )
     1                   * sflx (k,1) * atwid2(i  ) * atwidj2(j)
c
             vel         = 0.5 * ( v3(i+1,j-1,k  ) + v3(i+1,j,k  ) )
              q2         = dt * g31bi(i+1) * g32ai(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,2) = ( 0.5 + q1 ) * ( v2 (i+1,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,2) )
     2                   + ( 0.5 - q1 ) * ( v2 (i+1,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,2) )
              sflx (k,2) = ( mflx (i+1,j-1,k  ) + mflx (i+1,j  ,k  ) )
     1                   * sflx (k,2) * atwid2(i+1) * atwidj2(j)
c

             vel         = 0.5 * ( v3(i+2,j-1,k  ) + v3(i+2,j,k  ) )
              q2         = dt * g31bi(i+2) * g32ai(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,3) = ( 0.5 + q1 ) * ( v2 (i+2,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,3) )
     2                   + ( 0.5 - q1 ) * ( v2 (i+2,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,3) )
              sflx (k,3) = ( mflx (i+2,j-1,k  ) + mflx (i+2,j  ,k  ) )
     1                   * sflx (k,3) * atwid2(i+2) * atwidj2(j)
c


             vel         = 0.5 * ( v3(i+3,j-1,k  ) + v3(i+3,j,k  ) )
              q2         = dt * g31bi(i+3) * g32ai(j)
              xi         = ( vel           - vg3(k  ) ) * q2
              q1         = sign ( haf, xi )
              sflx (k,4) = ( 0.5 + q1 ) * ( v2 (i+3,j,k-1)
     1                   + ( dx3a(k-1) - xi ) * dq (k-1,4) )
     2                   + ( 0.5 - q1 ) * ( v2 (i+3,j,k  )
     3                   - ( dx3a(k  ) + xi ) * dq (k  ,4) )
              sflx (k,4) = ( mflx (i+3,j-1,k  ) + mflx (i+3,j  ,k  ) )
     1                   * sflx (k,4) * atwid2(i+3) * atwidj2(j)
c

2300       continue
c
           do 2370 k=kbeg,kend
             s2(i  ,j,k) = ( s2(i  ,j,k) * dvl3a(k)

     1                   - sflx(k+1,1) + sflx(k  ,1) ) * dvl3a i(k)

c
             s2(i+1,j,k) = ( s2(i+1,j,k) * dvl3a(k)

     1                   - sflx(k+1,2) + sflx(k  ,2) ) * dvl3a i(k)

c

             s2(i+2,j,k) = ( s2(i+2,j,k) * dvl3a(k)

     1                   - sflx(k+1,3) + sflx(k  ,3) ) * dvl3a i(k)

c


             s2(i+3,j,k) = ( s2(i+3,j,k) * dvl3a(k)

     1                   - sflx(k+1,4) + sflx(k  ,4) ) * dvl3a i(k)

c

2370       continue
c
c------------------------------ TRANSPORT S3 ---------------------------
c
c
c      Interpolate "v3" at the zone centers.
c
c       call x3fc3d ( v3, vel3, is, js, ie, je, iords3, sflx 3 )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 2470 k=kbeg-1,kend+1
             dqm       = (v3 (i  ,j,k  ) - v3 (i  ,j,k-1)) * dx3ai(k-1)
             dqp       = (v3 (i  ,j,k+1) - v3 (i  ,j,k  )) * dx3ai(k  )
             dq(k,1)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c
             dqm       = (v3 (i+1,j,k  ) - v3 (i+1,j,k-1)) * dx3ai(k-1)
             dqp       = (v3 (i+1,j,k+1) - v3 (i+1,j,k  )) * dx3ai(k  )
             dq(k,2)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c

             dqm       = (v3 (i+2,j,k  ) - v3 (i+2,j,k-1)) * dx3ai(k-1)
             dqp       = (v3 (i+2,j,k+1) - v3 (i+2,j,k  )) * dx3ai(k  )
             dq(k,3)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c


             dqm       = (v3 (i+3,j,k  ) - v3 (i+3,j,k-1)) * dx3ai(k-1)
             dqp       = (v3 (i+3,j,k+1) - v3 (i+3,j,k  )) * dx3ai(k  )
             dq(k,4)   = max ( dqm * dqp, zro )
     1                 * sign ( one, dqm + dqp )
     2                 / max ( abs ( dqm + dqp ), tiny )
c

2470       continue
c
c  2.  Choose time averaged, upwinded interface value.
c
c      Construct a k-average of "v3-vg3" to be used for interpolation.
c
c      Construct the 3-momentum flux at the 3-interfaces and perform
c  3-momentum advection.  Note that the timestep "dt" is hidden in the
c  mass flux.
c
           do 2500 k=kbeg-1,kend
             vel         = 0.5 * ( v3(i  ,j,k  ) - vg3(k  )
     1                           + v3(i  ,j,k+1) - vg3(k+1) )
              xi         = vel         * dt * g31bi(i  ) * g32bi(j)
              q1         = sign ( haf, xi )
              sflx (k,1) = ( 0.5 + q1 ) * ( v3(i  ,j,k  )
     1                   + ( dx3b(k  ) - xi ) * dq(k  ,1) )
     2                   + ( 0.5 - q1 ) * ( v3(i  ,j,k+1)
     3                   - ( dx3b(k+1) + xi ) * dq(k+1,1) )
              sflx (k,1) = ( mflx (i  ,j,k  ) + mflx (i  ,j,k+1) )
     1                   * sflx (k,1) * atwid3(i  ) * atwidj3(j)
c
             vel         = 0.5 * ( v3(i+1,j,k  ) - vg3(k  )
     1                           + v3(i+1,j,k+1) - vg3(k+1) )
              xi         = vel         * dt * g31bi(i+1) * g32bi(j)
              q1         = sign ( haf, xi )
              sflx (k,2) = ( 0.5 + q1 ) * ( v3(i+1,j,k  )
     1                   + ( dx3b(k  ) - xi ) * dq(k  ,2) )
     2                   + ( 0.5 - q1 ) * ( v3(i+1,j,k+1)
     3                   - ( dx3b(k+1) + xi ) * dq(k+1,2) )
              sflx (k,2) = ( mflx (i+1,j,k  ) + mflx (i+1,j,k+1) )
     1                   * sflx (k,2) * atwid3(i+1) * atwidj3(j)
c

             vel         = 0.5 * ( v3(i+2,j,k  ) - vg3(k  )
     1                           + v3(i+2,j,k+1) - vg3(k+1) )
              xi         = vel         * dt * g31bi(i+2) * g32bi(j)
              q1         = sign ( haf, xi )
              sflx (k,3) = ( 0.5 + q1 ) * ( v3(i+2,j,k  )
     1                   + ( dx3b(k  ) - xi ) * dq(k  ,3) )
     2                   + ( 0.5 - q1 ) * ( v3(i+2,j,k+1)
     3                   - ( dx3b(k+1) + xi ) * dq(k+1,3) )
              sflx (k,3) = ( mflx (i+2,j,k  ) + mflx (i+2,j,k+1) )
     1                   * sflx (k,3) * atwid3(i+2) * atwidj3(j)
c


             vel         = 0.5 * ( v3(i+3,j,k  ) - vg3(k  )
     1                           + v3(i+3,j,k+1) - vg3(k+1) )
              xi         = vel         * dt * g31bi(i+3) * g32bi(j)
              q1         = sign ( haf, xi )
              sflx (k,4) = ( 0.5 + q1 ) * ( v3(i+3,j,k  )
     1                   + ( dx3b(k  ) - xi ) * dq(k  ,4) )
     2                   + ( 0.5 - q1 ) * ( v3(i+3,j,k+1)
     3                   - ( dx3b(k+1) + xi ) * dq(k+1,4) )
              sflx (k,4) = ( mflx (i+3,j,k  ) + mflx (i+3,j,k+1) )
     1                   * sflx (k,4) * atwid3(i+3) * atwidj3(j)
c

2500       continue
c
           do 2570 k=kbeg,kend
             s3(i  ,j,k) = ( s3(i  ,j,k) * dvl3b(k)

     1                   - sflx(k  ,1) + sflx(k-1,1) ) * dvl3b i(k)

c
             s3(i+1,j,k) = ( s3(i+1,j,k) * dvl3b(k)

     1                   - sflx(k  ,2) + sflx(k-1,2) ) * dvl3b i(k)

c

             s3(i+2,j,k) = ( s3(i+2,j,k) * dvl3b(k)

     1                   - sflx(k  ,3) + sflx(k-1,3) ) * dvl3b i(k)

c


             s3(i+3,j,k) = ( s3(i+3,j,k) * dvl3b(k)

     1                   - sflx(k  ,4) + sflx(k-1,4) ) * dvl3b i(k)

c

2570       continue
2900     continue

c
3000   continue
c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////                 M O M X 3                 \\\\\\\\\\
c
c=======================================================================
c
c

invivomomx3_momx3__401

Real time: 1.724225e+09 -- Predicted time: 2.004700e+09

Callcount: 510

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
35	### 1	60.4422673304086	1.284566e+06	1.055832e+06	17.8
70	### 2	64.458244111349	1.366000e+05	5.417200e+04	60.3
15	### 3	191.098609236336	5.036288e+06	3.997516e+06	20.6
34	### 4	29.9909732741716	3.564161e+06	2.833364e+06	20.5
279	### 5	169.211519658728	5.016989e+06	4.643332e+06	7.4

                












































































c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////               L O R E N T Z               \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
c modified for SPEC CPU2006
c       subroutine lorentz (ibeg,iend,jbeg,jend,kbeg,kend
c     &                   ,u1,u2,u3,w1,w2,w3)
       subroutine lorentz (ibeg,iend,jbeg,jend,kbeg,kend
     &                   ,u1,u2,u3)


c
c    dac:zeus3d.lorentz <----- MoC estimate of transverse lorentz forces
c                                                          october, 1992
c
c    written by: David Clarke
c    modified 1: Mordecai-Mark Mac Low, December 1997 - March 1998
c                rewritten for ZEUS-MP 
c
c  PURPOSE:  Uses the Method of Characteristics (MoC) to compute the
c  transverse components of the Lorentz force and then accelerate the
c  velocities accordingly.  After a suggestion by John Hawley, these
c  source terms are computed separately from the MoC estimate of the
c  emfs (MOCEMFS) and before the magnetic field update.  This improves
c  stability of multi-dimensional Alfven waves.
c
c  MOCEMFS solves the induction equation without the use of operator
c  splitting.  Thus, the relevant characteristic velocities are v+/-va
c  and includes the flow velocity v (from the advection term v grad(B))
c  and the alfven velocity va (from the induction term va grad(B)).
c  Conversely, Euler's equation is operator split, and the advection
c  term (v grad(v)) is handled elsewhere (MOMX*).  Thus, the effective
c  characteristic velocities when estimating the transverse Lorentz
c  terms is simply +/-va (from the induction term va grad(v)).
c
c  See comments in MOCEMFS for further ideas regarding the Method of
c  Characteristics.
c
c  INPUT VARIABLES:
c
c    u[1,2,3] = old velocities
c
c  OUTPUT VARIABLES:
c
c    w[1,2,3] = velocities from ibeg to iend, jbeg to jend, kbeg to kend
c
c  LOCAL VARIABLES:
c    srd[n]    sqrt of spatially averaged density at [n]-face n=1,2,3
c    bave      spatially averaged density at edge
c    srdpi     1.0/srd[n] along the plus  alfven characteristic (A+)
c    srdmi     1.0/srd[n] along the minus alfven characteristic (A-)
c    valp      characteristic velocity along A+ (-va)
c    valm      characteristic velocity along A- (+va)
c    vpal      velocity interpolated to the time-centred footpoint of A+
c    vmal      velocity interpolated to the time-centred footpoint of A-
c    bpal      B-field  interpolated to the time-centred footpoint of A+
c    bmal      B-field  interpolated to the time-centred footpoint of A-
c    bstar     MoC estimate of b[n] used to evaluate st[n], n=1,2,3
c    st[n]     Transverse Lorentz force on the [n]-velocity, n=1,2,3
c
c  EXTERNALS:
c    
c   -----> these are now inlined (M-MML): X1ZC1D  , X2ZC1D  , X3ZC1D
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj

c
       integer       i       , j       , k      
       integer       ibeg,iend,jbeg,jend,kbeg,kend
       real*8          u1 (in,jn,kn),u2 (in,jn,kn),u3 (in,jn,kn)
commented out for SPEC CPU2006
c     &              ,w1 (in,jn,kn),w2 (in,jn,kn),w3 (in,jn,kn)

       real*8          absb ,q1, qv1, qv2, qb1, qb2, q3, dqm, dqp
     &              , xi, fact 
     &              , dv(ijkn), db(ijkn)
c
       real*8          bave    (ijkn), srdpi   (ijkn), srdmi   (ijkn)
     1             , valp    (ijkn), valm    (ijkn), vtmp    (ijkn)
     1             , btmp    (ijkn), vpal    (ijkn), vmal    (ijkn)
     1             , bpal    (ijkn), bmal    (ijkn), bstar   (ijkn)
c
       real*8          st1     (  in,  jn,  kn), st2  (  in,  jn,  kn)
     1             , st3     (  in,  jn,  kn), srd1 (  in,  jn,  kn)
     1             , srd2    (  in,  jn,  kn), srd3 (  in,  jn,  kn)
c
       equivalence   ( bave    , w1da     ), ( srdpi   , w1db     )
     1             , ( srdmi   , w1dc     ), ( vtmp    , w1dd     )
     2             , ( vpal    , w1de     ), ( vmal    , w1df     )
     2             , ( valp    , bpal    , w1dg     )
     1             , ( valm    , bmal    , w1dh     )
     8             , ( btmp    , bstar   , w1di     )
     9             , ( db      , w1dj     ),  ( dv     , w1dk     )
c
c      Routine MOCEMFS is expecting to find "srd1", "srd2", and "srd3" 
c  intact in worker arrays "wd3d", "we3d", and "wf3d" respectively.
c  [but MOCEMFS is in ZEUS-3D. does HSMOC also need these? M-MML 9.12.97 
c       so far, yes 4.3.98]
c
CPS: prevent overwritten of momenta.
C       equivalence   ( st1     , w3da     ), ( st2     , w3db     )
C     1             , ( st3     , w3dc     )
       equivalence   ( srd1    , w3di     ), ( srd2    , w3dj     )
     1             , ( srd3    , w3df     )
c
c      External statements
c
c
c
c-----------------------------------------------------------------------
c
c      Compute face-centred averages of density, initialise source terms
c  to zero.
c
       do 3 k=kbeg-1,kend+1
         do 2 j=jbeg-1,jend+1
           do 1 i=ibeg-1,iend+1
             srd1(i,j,k) = sqrt ( 0.5 * ( d (i,j,k) + d (i-1,j,k) ) )
             srd2(i,j,k) = sqrt ( 0.5 * ( d (i,j,k) + d (i,j-1,k) ) )
             srd3(i,j,k) = sqrt ( 0.5 * ( d (i,j,k) + d (i,j,k-1) ) )
             st1 (i,j,k) = 0.0
             st2 (i,j,k) = 0.0
             st3 (i,j,k) = 0.0
1          continue
2        continue
3      continue
c
c-----------------------------------------------------------------------
c---- 1-force ----------------------------------------------------------
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 2-direction, evaluate
c  "bstar" from "b1" to estimate the 2-transverse Lorentz force.
c
       do 50 k=kbeg,kend
         do 45 i=ibeg,iend+1
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 2-direction.
c
           do 10 j=jbeg,jend+1
             bave (j) = 0.5 * ( b2(i,j,k) + b2(i-1,j,k) )
             absb     = abs ( bave(j) )
             srdpi(j) = 1.0 / srd1(i,j  ,k)
             srdmi(j) = 1.0 / srd1(i,j-1,k)
             valp (j) =-absb * srdpi(j)
             valm (j) = absb * srdmi(j)
10         continue
c
c      Interpolate 1-D vectors of "u1" and "b1" in the 2-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 20 j=jbeg-2,jend+2
             vtmp(j) = v1(i,j,k) - vg1(i)
             btmp(j) = b1(i,j,k)
20         continue


c          call x2zc1d ( vtmp, valp, valm, iords1, istps1, k, i
c    1                 , g2a, g2ai, vpal, vmal )
c          call x2zc1d ( btmp, valp, valm, iordb1, istpb1, k, i
c    1                 , g2a, g2ai, bpal, bmal )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
c  Inline interpolation (following tranx*)
c

           do 22 j=jbeg-1,jend+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
22         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2ai(i)
           do 24 j=jbeg,jend+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = valp(j) * fact
             q3     = sign ( haf, xi )
             vpal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = valm(j) * fact
             q3     = sign ( haf, xi )
             vmal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 24       continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 30 j=jbeg,jend+1
             q1       = sign ( one, bave(j) )
             bstar(j) = ( bpal(j) * srdpi(j) + bmal(j) * srdmi(j)
     1                  + q1 * ( vpal(j) - vmal(j) ) )
     2                / ( srdpi(j) + srdmi(j) )
30         continue
c
c      Evaluate transverse Lorentz force.
c
           do 40 j=jbeg,jend
             st1(i,j,k) = ( bave (j+1) + bave (j) ) * g2ai(i)
     4                  * ( bstar(j+1) - bstar(j) ) * dx2ai(j)
40         continue
45       continue
50     continue
c
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 3-direction, evaluate
c  "bstar" from "b1" to estimate the 3-transverse Lorentz force.
c
       do 100 j=jbeg,jend
         do 95 i=ibeg,iend+1
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 3-direction.
c
           do 60 k=kbeg,kend+1
             bave (k) = 0.5 * ( b3(i,j,k) + b3(i-1,j,k) )
             absb     = abs ( bave(k) )
             srdpi(k) = 1.0 / srd1(i,j,k  )
             srdmi(k) = 1.0 / srd1(i,j,k-1)
             valp (k) =-absb * srdpi(k)
             valm (k) = absb * srdmi(k)
60         continue
c
c      Interpolate 1-D vectors of "u1" and "b1" in the 3-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 70 k=kbeg-2,kend+2
             vtmp(k) = v1(i,j,k) - vg1(i)
             btmp(k) = b1(i,j,k)
70         continue

c           call x3zc1d ( vtmp, valp, valm, iords1, istps1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, vpal, vmal )
c           call x3zc1d ( btmp, valp, valm, iordb1, istpb1, i, j
c     1                 , g31a, g31ai, g32b, g32bi, bpal, bmal )
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 72 k=kbeg-1,kend+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
72         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31ai(i) * g32bi(j)
           do 74 k=kbeg,kend+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = valp(k) * fact
             q3     = sign ( haf, xi )
             vpal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = valm(k) * fact
             q3     = sign ( haf, xi )
             vmal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
74         continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 80 k=kbeg,kend+1
             q1       = sign ( one, bave(k) )
             bstar(k) = ( bpal(k) * srdpi(k) + bmal(k) * srdmi(k)
     1                  + q1 * ( vpal(k) - vmal(k) ) )
     2                / ( srdpi(k) + srdmi(k) )
80         continue
c
c      Evaluate transverse Lorentz force.
c
           q1 = g31ai(i) * g32bi(j)
           do 90 k=kbeg,kend
             st1(i,j,k) = st1(i,j,k)
     1                  + ( bave (k+1) + bave (k) ) * q1
     4                  * ( bstar(k+1) - bstar(k) ) * dx3ai(k)
90         continue
95       continue
100      continue
c
110    continue
c
c-----------------------------------------------------------------------
c---- 2-force ----------------------------------------------------------
c-----------------------------------------------------------------------
c

       do 165 j=jbeg,jend+1
c
c      By following the Alfven velocity in the 3-direction, evaluate
c  "bstar" from "b2" to estimate the 3-transverse Lorentz force.
c
         do 160 i=ibeg,iend
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 3-direction.
c
           do 120 k=kbeg,kend+1
             bave (k) = 0.5 * ( b3(i,j,k) + b3(i,j-1,k) )
             absb     = abs ( bave(k) )
             srdpi(k) = 1.0 / srd2(i,j,k  )
             srdmi(k) = 1.0 / srd2(i,j,k-1)
             valp (k) =-absb * srdpi(k)
             valm (k) = absb * srdmi(k)
120        continue
c
c      Interpolate 1-D vectors of "u2" and "b2" in the 3-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 130 k=kbeg-2,kend+2
             vtmp(k) = v2(i,j,k) - vg2(j)
             btmp(k) = b2(i,j,k)
130        continue
c          call x3zc1d ( vtmp, valp, valm, iords2, istps2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, vpal, vmal )
c          call x3zc1d ( btmp, valp, valm, iordb2, istpb2, i, j
c    1                 , g31b, g31bi, g32a, g32ai, bpal, bmal )
c
c       subroutine x3zc1d ( q, vp, vm, iorder, isteep, i, j, g31, g31i
c     1                   , g32, g32i, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 132 k=kbeg-1,kend+1
             dqm      = ( vtmp(k  ) - vtmp(k-1) ) * dx3bi(k  )
             dqp      = ( vtmp(k+1) - vtmp(k  ) ) * dx3bi(k+1)
             dv (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(k  ) - btmp(k-1) ) * dx3bi(k  )
             dqp      = ( btmp(k+1) - btmp(k  ) ) * dx3bi(k+1)
             db (k  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
132         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g31bi(i) * g32ai(j)
           do 134 k=kbeg,kend+1
             qv1    = vtmp(k-1) + dx3a(k-1) * dv (k-1)
             qv2    = vtmp(k  ) - dx3a(k  ) * dv (k  )
             qb1    = btmp(k-1) + dx3a(k-1) * db (k-1)
             qb2    = btmp(k  ) - dx3a(k  ) * db (k  )
c  
             xi     = valp(k) * fact
             q3     = sign ( haf, xi )
             vpal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bpal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
c
             xi     = valm(k) * fact
             q3     = sign ( haf, xi )
             vmal(k)= ( 0.5 + q3 ) * ( qv1 - xi * dv (k-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (k  ) )
             bmal(k)= ( 0.5 + q3 ) * ( qb1 - xi * db (k-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (k  ) )
134         continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 140 k=kbeg,kend+1
             q1       = sign ( one, bave(k) )
             bstar(k) = ( bpal(k) * srdpi(k) + bmal(k) * srdmi(k)
     1                  + q1 * ( vpal(k) - vmal(k) ) )
     2                / ( srdpi(k) + srdmi(k) )
140        continue
c
c      Evaluate transverse Lorentz force.
c
           q1 = g31bi(i) * g32ai(j)
           do 150 k=kbeg,kend
             st2(i,j,k) = ( bave (k+1) + bave (k) ) * q1
     4                  * ( bstar(k+1) - bstar(k) ) * dx3ai(k)
150        continue
160      continue
165    continue
c
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 1-direction, evaluate
c  "bstar" from "b2" to estimate the 1-transverse Lorentz force.
c
c *if def,IRIX.and.SGIMP
c C*$*ASSERT CONCURRENT CALL
c *endif IRIX.and.SGIMP
       do 210 k=kbeg,kend
         do 205 j=jbeg,jend+1
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 1-direction.
c
           do 170 i=ibeg,iend+1
             bave (i) = 0.5 * ( b1(i,j,k) + b1(i,j-1,k) )
             absb     = abs ( bave(i) )
             srdpi(i) = 1.0 / srd2(i  ,j,k)
             srdmi(i) = 1.0 / srd2(i-1,j,k)
             valp (i) =-absb * srdpi(i)
             valm (i) = absb * srdmi(i)
170        continue
c
c      Interpolate 1-D vectors of "u2" and "b2" in the 1-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 180 i=ibeg-2,iend+2
             vtmp(i) = v2(i,j,k) - vg2(j)
             btmp(i) = b2(i,j,k)
180        continue
c          call x1zc1d ( vtmp, valp, valm, iords2, istps2, j, k
c    1                 , vpal, vmal )
c          call x1zc1d ( btmp, valp, valm, iordb2, istpb2, j, k
c    1                 , bpal, bmal )
c       subroutine x1zc1d ( q, vp, vm, iorder, isteep, j, k, qp, qm )

c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 182 i=ibeg-1,iend+1
             dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
             dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
             dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 182       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 184 i=ibeg,iend+1
             qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
             qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
             qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c
             xi     = valp(i) * dt
             q3     = sign ( haf, xi )
             vpal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bpal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
             xi     = valm(i) * dt
             q3     = sign ( haf, xi )
             vmal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bmal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
184        continue

c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 190 i=ibeg,iend+1
             q1       = sign ( one, bave(i) )
             bstar(i) = ( bpal(i) * srdpi(i) + bmal(i) * srdmi(i)
     1                  + q1 * ( vpal(i) - vmal(i) ) ) * g2a(i)
     2                / ( srdpi(i) + srdmi(i) )
190        continue
c
c      Evaluate transverse Lorentz force.  Note that the metric
c  factor "g2a" has been absorbed into "bstar".
c
           do 200 i=ibeg,iend
             st2(i,j,k) = st2(i,j,k)
     2                  + ( bave (i+1) + bave (i) ) * g2bi(i)
     4                  * ( bstar(i+1) - bstar(i) ) * dx1ai(i)
200        continue
205      continue
210    continue
c
220    continue
c
c-----------------------------------------------------------------------
c---- 3-force ----------------------------------------------------------
c-----------------------------------------------------------------------
c
c *if def,IRIX.and.SGIMP
c C*$*ASSERT CONCURRENT CALL
c *endif IRIX.and.SGIMP
       do 330 k=kbeg,kend+1
c
c      By following the Alfven velocity in the 1-direction, evaluate
c  "bstar" from "b3" to estimate the 1-transverse Lorentz force.
c
         do 270 j=jbeg,jend
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 1-direction.
c
           do 230 i=ibeg,iend+1
             bave (i) = 0.5 * ( b1(i,j,k) + b1(i,j,k-1) )
             absb     = abs ( bave(i) )
             srdpi(i) = 1.0 / srd3(i  ,j,k)
             srdmi(i) = 1.0 / srd3(i-1,j,k)
             valp (i) =-absb * srdpi(i)
             valm (i) = absb * srdmi(i)
230        continue
c
c      Interpolate 1-D vectors of "u3" and "b3" in the 1-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 240 i=ibeg-2,iend+2
             vtmp(i) = v3(i,j,k) - vg3(k)
             btmp(i) = b3(i,j,k)
240        continue
c           call x1zc1d ( vtmp, valp, valm, iords3, istps3, j, k
c     1                 , vpal, vmal )
c           call x1zc1d ( btmp, valp, valm, iordb3, istpb3, j, k
c     1                 , bpal, bmal )
c       subroutine x1zc1d ( q, vp, vm, iorder, isteep, j, k, qp, qm )
c
c  1.  Evaluate monotonised, van Leer difference in "q" across the zone.
c
           do 242 i=ibeg-1,iend+1
             dqm      = ( vtmp(i  ) - vtmp(i-1) ) * dx1bi(i  )
             dqp      = ( vtmp(i+1) - vtmp(i  ) ) * dx1bi(i+1)
             dv (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm      = ( btmp(i  ) - btmp(i-1) ) * dx1bi(i  )
             dqp      = ( btmp(i+1) - btmp(i  ) ) * dx1bi(i+1)
             db (i  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
 242       continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           do 244 i=ibeg,iend+1
             qv1    = vtmp(i-1) + dx1a(i-1) * dv (i-1)
             qv2    = vtmp(i  ) - dx1a(i  ) * dv (i  )
             qb1    = btmp(i-1) + dx1a(i-1) * db (i-1)
             qb2    = btmp(i  ) - dx1a(i  ) * db (i  )
c
             xi     = valp(i) * dt
             q3     = sign ( haf, xi )
             vpal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bpal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
c
             xi     = valm(i) * dt
             q3     = sign ( haf, xi )
             vmal(i)= ( 0.5 + q3 ) * ( qv1 - xi * dv (i-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (i  ) )
             bmal(i)= ( 0.5 + q3 ) * ( qb1 - xi * db (i-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (i  ) )
244        continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 250 i=ibeg,iend+1
             q1       = sign ( one, bave(i) )
             bstar(i) = ( bpal(i) * srdpi(i) + bmal(i) * srdmi(i)
     1                  + q1 * ( vpal(i) - vmal(i) ) ) * g31a(i)
     2                / ( srdpi(i) + srdmi(i) )
250        continue
c
c      Evaluate transverse Lorentz force.  Note that the metric
c  factor "g31a" has been absorbed into "bstar".
c
           do 260 i=ibeg,iend
             st3(i,j,k) = ( bave (i+1) + bave (i) ) * g31bi(i)
     4                  * ( bstar(i+1) - bstar(i) ) * dx1ai(i)
260        continue
270      continue
c
c-----------------------------------------------------------------------
c
c      By following the Alfven velocity in the 2-direction, evaluate
c  "bstar" from "b3" to estimate the 2-transverse Lorentz force.
c
         do 320 i=ibeg,iend
c
c      Select an effective density and determine the Alfven speed for
c  each Alfven characteristic in the 2-direction.
c
           do 280 j=jbeg,jend+1
             bave (j) = 0.5 * ( b2(i,j,k) + b2(i,j,k-1) )
             absb     = abs ( bave(j) )
             srdpi(j) = 1.0 / srd3(i,j  ,k)
             srdmi(j) = 1.0 / srd3(i,j-1,k)
             valp (j) =-absb * srdpi(j)
             valm (j) = absb * srdmi(j)
280        continue
c
c      Interpolate 1-D vectors of "u3" and "b3" in the 2-direction to
c  the footpoints of both Alfven characteristics.
c
C modified by PS
           do 290 j=jbeg-2,jend+2
             vtmp(j) = v3(i,j,k) - vg3(k)
             btmp(j) = b3(i,j,k)
290        continue
c           call x2zc1d ( vtmp, valp, valm, iords3, istps3, k, i
c     1                 , g2b, g2bi, vpal, vmal )
c           call x2zc1d ( btmp, valp, valm, iordb3, istpb3, k, i
c     1                 , g2b, g2bi, bpal, bmal )
c       subroutine x2zc1d ( q, vp, vm, iorder, isteep, k, i, g2, g2i
c     1                   , qp, qm )
c
            do 292 j=jbeg-1,jend+1
             dqm      = ( vtmp(j  ) - vtmp(j-1) ) * dx2bi(j  )
             dqp      = ( vtmp(j+1) - vtmp(j  ) ) * dx2bi(j+1)
             dv (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )

             dqm     = ( btmp(j  ) - btmp(j-1) ) * dx2bi(j  )
             dqp     = ( btmp(j+1) - btmp(j  ) ) * dx2bi(j+1)
             db (j  ) = max ( dqm * dqp, zro )
     1                * sign ( one, dqm + dqp )
     2                / max ( abs ( dqm + dqp ), tiny )
292         continue
c
c  2.  Perform an upwinded interpolation of "q" to the time-centred
c      bases of the characteristics.
c
           fact = dt * g2bi(i)
           do 294 j=jbeg,jend+1
             qv1    = vtmp(j-1) + dx2a(j-1) * dv (j-1)
             qv2    = vtmp(j  ) - dx2a(j  ) * dv (j  )
             qb1    = btmp(j-1) + dx2a(j-1) * db (j-1)
             qb2    = btmp(j  ) - dx2a(j  ) * db (j  )
c
             xi     = valp(j) * fact
             q3     = sign ( haf, xi )
             vpal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bpal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )
c
             xi     = valm(j) * fact
             q3     = sign ( haf, xi )
             vmal(j)= ( 0.5 + q3 ) * ( qv1 - xi * dv (j-1) )
     1              + ( 0.5 - q3 ) * ( qv2 - xi * dv (j  ) )
             bmal(j)= ( 0.5 + q3 ) * ( qb1 - xi * db (j-1) )
     1              + ( 0.5 - q3 ) * ( qb2 - xi * db (j  ) )

 294       continue
c
c      Evaluate "bstar" by solving the characteristic equations.
c
           do 300 j=jbeg,jend+1
             q1       = sign ( one, bave(j) )
             bstar(j) = ( bpal(j) * srdpi(j) + bmal(j) * srdmi(j)
     1                  + q1 * ( vpal(j) - vmal(j) ) ) * g32a(j)
     1                / ( srdpi(j) + srdmi(j) )
300        continue
c
c      Evaluate transverse Lorentz force.  Note that the metric
c  factor "g32a" has been absorbed into "bstar".
c
           do 310 j=jbeg,jend
             st3(i,j,k) = st3(i,j,k)
     2                  + ( bave (j+1) + bave (j) ) * g2ai(i) * g32bi(j)
     4                  * ( bstar(j+1) - bstar(j) ) * dx2ai(j)
310        continue
320      continue
c
330    continue
c
c-----------------------------------------------------------------------
c
c      Accelerate velocities and set boundaries.
c
       q1 = 0.5 * dt

c modified for SPEC CPU2006
c       do 360 k=kbeg,kend
c         do 350 j=jbeg,jend
c           do 340 i=ibeg,iend
c             w1(i,j,k) = u1(i,j,k) + q1 * st1(i,j,k) / srd1(i,j,k)**2
c             w2(i,j,k) = u2(i,j,k) + q1 * st2(i,j,k) / srd2(i,j,k)**2
c             w3(i,j,k) = u3(i,j,k) + q1 * st3(i,j,k) / srd3(i,j,k)**2
c340        continue
c350      continue
c360    continue
       do 360 k=kbeg,kend
         do 350 j=jbeg,jend
           do 340 i=ibeg,iend
             u1(i,j,k) = v1(i,j,k) + q1 * st1(i,j,k) / srd1(i,j,k)**2
             u2(i,j,k) = v2(i,j,k) + q1 * st2(i,j,k) / srd2(i,j,k)**2
             u3(i,j,k) = v3(i,j,k) + q1 * st3(i,j,k) / srd3(i,j,k)**2
340        continue
350      continue
360    continue
c


c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////               L O R E N T Z               \\\\\\\\\\
c
c=======================================================================
c

invivolorentz_lorentz__840

Real time: 1.688676e+09 -- Predicted time: 1.819827e+09

Callcount: 270

Invocation	Cluster	Part	Invitro (cycles)	Invivo (cycles)	Error (%)
151	### 1	93.2953476435209	1.642816e+07	1.531310e+07	6.7
177	### 2	197.34637714496	1.455084e+06	1.304220e+06	10.3

                












































































c=======================================================================
c
c    \\\\\\\\\\      B E G I N   S U B R O U T I N E      //////////
c    //////////                T R A N X 1                \\\\\\\\\\
c
c                            Developed by
c                Laboratory of Computational Astrophysics
c               University of Illinois at Urbana-Champaign
c
c=======================================================================
c
       subroutine tranx1 (ibeg,iend,jbeg,jend,kbeg,kend
     &                   ,dlo,den

     &                   ,eod,edn


     &                   ,mflx)
c
c    dac:zeus3d.tranx1 <----- transports zone-centred variables along x1
c    from jms:zeus2d.tranx1, mln:zeus04.tranz                  may, 1990
c
c    written by: David Clarke
c    modified 1: June 1992, by David Clarke; added the total energy
c                option originally designed by Byung-IL Jun.
c    modified 2: Feb. 20, 1996 by Robert Fiedler; completely rewritten
c                for ZEUS-MP.
c    modified 3: Dec. 19, 1996 by Robert Fiedler; added radiation
c
c  PURPOSE:  Transports all zone centred variables in the 1-direction
c  only.  Currently transported are:
c
c                      mass   density
c                      energy density
c
c  The consistent advection algorithm, in which mass fluxes are used to
c  construct the fluxes of all variables across the interfaces, is used
c  for all hydrodynamical variables.  Thus, the mass fluxes are passed
c  to MOMX1 on order to transport the momenta as well.  The magnetic
c  field components are treated separately from the mass fluxes in CT.
c  Interpolations are done in-line.
c
c  INPUT VARIABLES: 
c    ibeg,iend,jbeg,jend,kbeg,kend  index ranges to cover.
c    dlo      mass            density at previous substep.
c    eod      specific energy density at previous substep; equals
c             (e+p)/d  if TOTAL_ENERGY is defined.
c
c BOUNDARY VALUES USED:
c
c    Macro defined  var   ii    oi    ij    oj    ik    ok
c    -------------  ---  ----  ----  ----  ----  ----  ----
c                    d   is-3  ie+2  js-1        ks-1
c                   e/d  is-2  ie+2
c                    u1  is-1  ie+1  js-1        ks-1
c    TOTAL_ENERGY    u2                    je+1
c    TOTAL_ENERGY    u3                                ke+1
c
c  OUTPUT VARIABLES:
c    den      updated mass            density.
c    edn      updated specific energy density.
c    mflx     mass flux (in the 1-direction)
c
c  LOCAL VARIABLES:
c    atwid    effective cross sectional area of the 1-interfaces
c    etwid    interpolated specific energy densities (e/d) at all
c             1-interfaces
c    eflx     energy density flux across all 1-interfaces  (reuse etwid)
c    dtwid    interpolated mass densities at all 1-interfaces
c    dflx     mass density flux across all 1-interfaces    (reuse dtwid)
c
c  EXTERNALS:
c
c-----------------------------------------------------------------------
c
       implicit NONE




      integer in, jn, kn, ijkn, neqm
      parameter(in =           128+5
     &        , jn =           128+5
     &        , kn =           128+5)
      parameter(ijkn =   128+5)
      parameter(neqm = 1)
c
      integer nbvar
      parameter(nbvar = 14)

c
      real*8    pi, tiny, huge
      parameter(pi   = 3.14159265358979324)
      parameter(tiny =          1.000d-99 )
      parameter(huge =          1.000d+99 )
c
      real*8    zro, one, two, haf
      parameter(zro  = 0.0 )
      parameter(one  = 1.0 )
      parameter(two  = 2.0 )
      parameter(haf  = 0.5 )
c
      integer nbuff,mreq
      parameter(nbuff = 40, mreq=300)

      real*8
     . b1floor   ,b2floor   ,b3floor   ,ciso      
     .,courno    ,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt        ,dtdump 
     .,dthdf     ,dthist    ,dtmin     ,dttsl
CJH  .,dtqqi2 
     .,dtqqi2    ,dtnri2    ,dtrdi2    ,dtimrdi2
     .,dtusr
     .,efloor    ,erfloor   ,gamma     ,gamm1
     .,qcon      ,qlin 
     .,tdump
     .,thdf      ,thist     ,time      ,tlim      ,cpulim
     .,trem      ,tsave     ,ttsl
     .,tused     ,tusr

     .,v1floor   ,v2floor   ,v3floor 
     .,emf1floor ,emf2floor ,emf3floor 
     .,gpfloor

      integer

     . ifsen(6)

     .,idebug
     .,iordb1    ,iordb2    ,iordb3    ,iordd
     .,iorde     ,iorder    ,iords1    ,iords2
     .,iords3
     .,istpb1    ,istpb2    ,istpb3    ,istpd     ,istpe     ,istper
     .,istps1    ,istps2    ,istps3
C     .,isymm
     .,ix1x2x3   ,jx1x2x3
     .,nhy       ,nlim      ,nred      ,mbatch
     .,nwarn     ,nseq      ,flstat
c output file handles (efh 04/15/99)
     .,ioinp     ,iotsl     ,iolog     ,iohst     ,iomov     ,iores
     .,ioshl

      common /rootr/ 
     . b1floor ,b2floor ,b3floor ,ciso    ,courno
     .,dfloor
     .,dtal    ,dtcs    ,dtv1    ,dtv2    ,dtv3
     .,dtqq    ,dtnew

     .,dtrd
     .,dt      ,dtdump  ,dthdf
     .,dthist  ,dtmin   ,dttsl
CJH  .,dtqqi2  ,dtusr
     .,dtqqi2  ,dtusr   ,dtnri2  ,dtrdi2  ,dtimrdi2
     .,efloor  ,erfloor ,gamma   ,gamm1
     .,qcon    ,qlin
     .,tdump   ,thdf    ,thist
     .,time    ,tlim    ,cpulim  ,trem    ,tsave
     .,tused   ,tusr    ,ttsl    

     .,v1floor ,v2floor ,v3floor
     .,emf1floor ,emf2floor ,emf3floor
     .,gpfloor

      common /rooti/ 
     . ifsen   ,idebug
     .,iordb1  ,iordb2
     .,iordb3  ,iordd   ,iorde   ,iorder  ,iords1
     .,iords2  ,iords3 
     .,istpb1  ,istpb2  ,istpb3  ,istpd   ,istpe   ,istper
     .,istps1  ,istps2  ,istps3
C     .,isymm   
     .,ix1x2x3 ,jx1x2x3
     .,nhy     ,nlim    ,nred    ,mbatch
     .,nwarn   ,nseq    ,flstat
     .,ioinp   ,iotsl   ,iolog   ,iohst   ,iomov   ,iores
     .,ioshl

      character*2  id
      character*15 hdffile, hstfile, resfile, usrfile

      character*8  tslfile

      common /chroot2/  id
      common /chroot1/  hdffile, hstfile, resfile, usrfile

     .,tslfile

      real*8   d (in,jn,kn), e (in,jn,kn),
     1       v1(in,jn,kn), v2(in,jn,kn), v3(in,jn,kn)

      real*8   b1(in,jn,kn), b2(in,jn,kn), b3(in,jn,kn)




      common /fieldr/  d, e, v1, v2, v3

      common /fieldr/  b1, b2, b3




       integer is, ie, js, je, ks, ke
     &       , ia, ja, ka, igcon
       integer nx1z, nx2z, nx3z
c
       common /gridcomi/
     &   is, ie, js, je, ks, ke
     & , ia, ja, ka, igcon
     & , nx1z, nx2z, nx3z
c
       real*8  x1a   (in),  x2a   (jn),  x3a   (kn)
     &     , x1ai  (in),  x2ai  (jn),  x3ai  (kn)
     &     ,dx1a   (in), dx2a   (jn), dx3a   (kn)
     &     ,dx1ai  (in), dx2ai  (jn), dx3ai  (kn)
     &     ,vol1a  (in), vol2a  (jn), vol3a  (kn)
     &     ,dvl1a  (in), dvl2a  (jn), dvl3a  (kn)
     &     ,dvl1ai (in), dvl2ai (jn), dvl3ai (kn)
       real*8  g2a   (in), g31a   (in), dg2ad1 (in)
     &     , g2ai  (in), g31ai  (in), dg31ad1(in)
       real*8  g32a  (jn), g32ai  (jn), dg32ad2(jn)
     &     , g4 a  (jn)
c
       real*8  x1b   (in),  x2b   (jn),  x3b   (kn)
     &     , x1bi  (in),  x2bi  (jn),  x3bi  (kn)
     &     ,dx1b   (in), dx2b   (jn), dx3b   (kn)
     &     ,dx1bi  (in), dx2bi  (jn), dx3bi  (kn)
     &     ,vol1b  (in), vol2b  (jn), vol3b  (kn)
     &     ,dvl1b  (in), dvl2b  (jn), dvl3b  (kn)
     &     ,dvl1bi (in), dvl2bi (jn), dvl3bi (kn)
       real*8  g2b   (in), g31b   (in), dg2bd1 (in) 
     &     , g2bi  (in), g31bi  (in), dg31bd1(in)
       real*8  g32b  (jn), g32bi  (jn), dg32bd2(jn)
     &     , g4 b  (jn)
c
       real*8   vg1  (in),   vg2  (jn),   vg3  (kn)
       real*8 x1fac, x2fac, x3fac
c
       common /gridcomr/
     &       x1a   ,  x2a   ,  x3a   
     &     , x1ai  ,  x2ai  ,  x3ai  
     &     ,dx1a   , dx2a   , dx3a   
     &     ,dx1ai  , dx2ai  , dx3ai  
     &     ,vol1a  , vol2a  , vol3a  
     &     ,dvl1a  , dvl2a  , dvl3a  
     &     ,dvl1ai , dvl2ai , dvl3ai 
     &     , g2a   , g31a   , dg2ad1 
     &     , g2ai  , g31ai  , dg31ad1
     &     , g32a  , g32ai  , dg32ad2
     &     , g4 a
c
       common /gridcomr/
     &       x1b   ,  x2b   ,  x3b   
     &     , x1bi  ,  x2bi  ,  x3bi  
     &     ,dx1b   , dx2b   , dx3b   
     &     ,dx1bi  , dx2bi  , dx3bi  
     &     ,vol1b  , vol2b  , vol3b  
     &     ,dvl1b  , dvl2b  , dvl3b  
     &     ,dvl1bi , dvl2bi , dvl3bi 
     &     , g2b   , g31b   , dg2bd1  
     &     , g2bi  , g31bi  , dg31bd1
     &     , g32b  , g32bi  , dg32bd2
     &     , g4 b
c
       common /gridcomr/
     &        vg1  ,   vg2  ,   vg3  
     &     , x1fac , x2fac  , x3fac
c


      real*8  w1da(ijkn    ) , w1db(ijkn    ) , w1dc(ijkn    )
     &,     w1dd(ijkn    ) , w1de(ijkn    ) , w1df(ijkn    )
     &,     w1dg(ijkn    ) , w1dh(ijkn    ) , w1di(ijkn    )
     &,     w1dj(ijkn    ) , w1dk(ijkn    ) , w1dl(ijkn    )
     &,     w1dm(ijkn    ) , w1dn(ijkn    ) , w1do(ijkn    )
     &,     w1dp(ijkn    ) , w1dq(ijkn    ) , w1dr(ijkn    )
     &,     w1ds(ijkn    ) , w1dt(ijkn    ) , w1du(ijkn    )

c added 1D arrays w1dk through w1du for   M-MML 4 Mar 98

      real*8  w3da(in,jn,kn) , w3db(in,jn,kn) , w3dc(in,jn,kn)
     &,     w3dd(in,jn,kn) , w3de(in,jn,kn) , w3df(in,jn,kn)
     &,     w3dg(in,jn,kn)
     &,     w3di(in,jn,kn) , w3dj(in,jn,kn)


      common /scratch/  w1da,w1db,w1dc,w1dd,w1de,w1df
     &,                 w1dg,w1dh,w1di,w1dj,w1dk,w1dl,w1dm
     &,                 w1dn,w1do,w1dp,w1dq,w1dr,w1ds,w1dt
     &,                 w1du
      common /scratch/  w3da,w3db,w3dc,w3dd,w3de,w3df,w3dg
     &,                 w3di,w3dj


      real*8     fiis(nbvar),  fois(nbvar)
     &      ,  fijs(nbvar),  fojs(nbvar)
     &      ,  fiks(nbvar),  foks(nbvar)
      integer  niis( 3),  nois( 3)
     &      ,  nijs( 3),  nojs( 3)
     &      ,  niks( 3),  noks( 3)
      integer  bvstat(6,nbvar)

      integer  niib(jn,kn), niib2(jn,kn), niib3(jn,kn), niib23(jn,kn)
     &      ,  noib(jn,kn), noib2(jn,kn), noib3(jn,kn), noib23(jn,kn)
     &      ,  nijb(in,kn), nijb3(in,kn), nijb1(in,kn), nijb31(in,kn)
     &      ,  nojb(in,kn), nojb3(in,kn), nojb1(in,kn), nojb31(in,kn)
     &      ,  nikb(in,jn), nikb1(in,jn), nikb2(in,jn), nikb12(in,jn)
     &      ,  nokb(in,jn), nokb1(in,jn), nokb2(in,jn), nokb12(in,jn)


      real*8    diib(jn,kn,3),  doib(jn,kn,3)
     &     ,  dijb(in,kn,3),  dojb(in,kn,3)
     &     ,  dikb(in,jn,3),  dokb(in,jn,3)
      real*8    eiib(jn,kn,2),  eoib(jn,kn,2)
     &     ,  eijb(in,kn,2),  eojb(in,kn,2)
     &     ,  eikb(in,jn,2),  eokb(in,jn,2)
      real*8   v1iib(jn,kn,2), v1oib(jn,kn,2)
     &     , v1ijb(in,kn,2), v1ojb(in,kn,2)
     &     , v1ikb(in,jn,2), v1okb(in,jn,2)
      real*8   v2iib(jn,kn,2), v2oib(jn,kn,2)
     &     , v2ijb(in,kn,2), v2ojb(in,kn,2)
     &     , v2ikb(in,jn,2), v2okb(in,jn,2)
      real*8   v3iib(jn,kn,2), v3oib(jn,kn,2)
     &     , v3ijb(in,kn,2), v3ojb(in,kn,2)
     &     , v3ikb(in,jn,2), v3okb(in,jn,2)

      real*8   b1iib(jn,kn,2), b1oib(jn,kn,2)
     &     , b1ijb(in,kn,2), b1ojb(in,kn,2)
     &     , b1ikb(in,jn,2), b1okb(in,jn,2)
      real*8   b2iib(jn,kn,2), b2oib(jn,kn,2)
     &     , b2ijb(in,kn,2), b2ojb(in,kn,2)
     &     , b2ikb(in,jn,2), b2okb(in,jn,2)
      real*8   b3iib(jn,kn,2), b3oib(jn,kn,2)
     &     , b3ijb(in,kn,2), b3ojb(in,kn,2)
     &     , b3ikb(in,jn,2), b3okb(in,jn,2)
      real*8   emf1iib(jn,kn,3), emf1oib(jn,kn,3)
     &     , emf1ijb(in,kn,3), emf1ojb(in,kn,3)
     &     , emf1ikb(in,jn,3), emf1okb(in,jn,3)
      real*8   emf2iib(jn,kn,3), emf2oib(jn,kn,3)
     &     , emf2ijb(in,kn,3), emf2ojb(in,kn,3)
     &     , emf2ikb(in,jn,3), emf2okb(in,jn,3)
      real*8   emf3iib(jn,kn,3), emf3oib(jn,kn,3)
     &     , emf3ijb(in,kn,3), emf3ojb(in,kn,3)
     &     , emf3ikb(in,jn,3), emf3okb(in,jn,3)




      common /bndryr/
     &   fiis,  fois,  fijs,  fojs,  fiks,  foks
     & , diib,  doib,  dijb,  dojb,  dikb,  dokb
     & , eiib,  eoib,  eijb,  eojb,  eikb,  eokb
     & ,v1iib, v1oib, v1ijb, v1ojb, v1ikb, v1okb
     & ,v2iib, v2oib, v2ijb, v2ojb, v2ikb, v2okb
     & ,v3iib, v3oib, v3ijb, v3ojb, v3ikb, v3okb

     & ,b1iib, b1oib, b1ijb, b1ojb, b1ikb, b1okb
     & ,b2iib, b2oib, b2ijb, b2ojb, b2ikb, b2okb
     & ,b3iib, b3oib, b3ijb, b3ojb, b3ikb, b3okb
     & ,emf1iib, emf1oib, emf1ijb, emf1ojb, emf1ikb, emf1okb
     & ,emf2iib, emf2oib, emf2ijb, emf2ojb, emf2ikb, emf2okb
     & ,emf3iib, emf3oib, emf3ijb, emf3ojb, emf3ikb, emf3okb




      common /bndryi/   niis,   nois,   nijs,   nojs,   niks,   noks
     &      ,  bvstat
     &      ,  niib, niib2, niib3, niib23
     &      ,  noib, noib2, noib3, noib23
     &      ,  nijb, nijb3, nijb1, nijb31
     &      ,  nojb, nojb3, nojb1, nojb31
     &      ,  nikb, nikb1, nikb2, nikb12
     &      ,  nokb, nokb1, nokb2, nokb12



      integer stat, req


      logical periodic(3)
      logical reorder
      integer myid, myid_w, nprocs, nprocs_w, coords(3)
      integer ierr, nreq, nsub
      integer comm3d
      integer ntiles(3)
      integer n1m, n1p, n2m, n2p, n3m, n3p
      integer i_slice,j_slice,k_slice
      integer ils_slice,jls_slice,kls_slice
      integer ilsm_slice,jlsm_slice,klsm_slice
      integer ibuf_in(nbuff), ibuf_out(nbuff)
      real*8    buf_in(nbuff), buf_out(nbuff)
      common /mpicomi/ myid, myid_w, nprocs, nprocs_w, coords
     &               , comm3d, ntiles
     &               , n1m, n1p, n2m, n2p, n3m, n3p
     &               , i_slice, j_slice, k_slice
     &               , ils_slice, jls_slice, kls_slice
     &               , ilsm_slice, jlsm_slice, klsm_slice
     &               , ibuf_in, ibuf_out
     &               , stat, req, ierr, nreq, nsub
      common /mpicoml/ periodic, reorder
      common /mpicomr/ buf_in, buf_out
c
       integer i, j, k, ibeg,iend,jbeg,jend,kbeg,kend
c
       real*8    dqm,dqp, xi,q1
       real*8        atwid (ijkn),  mflux (ijkn)
     &           , dtwid (ijkn),  dd    (ijkn)

     &           , etwid (ijkn),  deod  (ijkn)


c
       real*8        mflx    (  in,  jn,  kn)
       real*8  dlo(in,jn,kn), den(in,jn,kn)

     &      ,eod(in,jn,kn), edn(in,jn,kn)


c
       equivalence (atwid , w1da), (mflux , w1db)
     &           , (dtwid , w1dc), (dd    , w1dd)

     &           , (etwid , w1de), (deod  , w1df)


c
c-----------------------------------------------------------------------
c
c Compute time-centered area factors.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
       do 10 i=ibeg-1,iend+1

         atwid (i)  =       g2a (i) * g31a (i)

10     continue
c
c Transport all zone-centered quantities in the 1 direction.
c Note that transporting v1 in MOMX1 will require the mass flux at 
c x1a(is-1).  To get it from the field variables, we need d at is-3.
c We also need mflx at js-1 and ks-1 for i=is,ie+1 for v2 and v3.
c Extend loop indices to compute mass fluxes beyond inner borders.
c Be careful to assign values to mflx, (and den, edn) only
c within the range (ibeg:iend,jbeg:jend,kbeg:kend) when these
c indices are not on the borders, so that they can't get overwritten
c when this routine is called with various index ranges.
c
         do 100 k=kbeg-1,kend
           do 90 j=jbeg-1,jend
c
c   Interpolate to obtain zone-centered quantities at zone faces.
c
c     1.  Evaluate monotonised, van Leer differences across the zone.
c
             if (ibeg .eq. is) then  
c  Need d(is-3) from neighbor.
               i         = is - 2
               dqm       = (dlo(i  ,j,k) - diib (j,k,3)) * dx1bi(i  )
               dqp       = (dlo(i+1,j,k) - dlo(i  ,j,k)) * dx1bi(i+1)
               dd(i)     = max ( dqm * dqp, zro )
     1                   * sign ( one, dqm + dqp )
     2                   / max ( abs ( dqm + dqp ), tiny )
c Not valid, but we don't use it.
               deod  (i) = zro  


             endif
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
             do 30 i=max(ibeg-2,is-1),iend+1
               dqm       = (dlo(i  ,j,k) - dlo(i-1,j,k)) * dx1bi(i  )
               dqp       = (dlo(i+1,j,k) - dlo(i  ,j,k)) * dx1bi(i+1)
               dd(i)     = max ( dqm * dqp, zro )
     1                   * sign ( one, dqm + dqp )
     2                   / max ( abs ( dqm + dqp ), tiny )

               dqm       = (eod(i  ,j,k) - eod(i-1,j,k)) * dx1bi(i  )
               dqp       = (eod(i+1,j,k) - eod(i  ,j,k)) * dx1bi(i+1)
               deod(i)   = max ( dqm * dqp, zro )
     1                   * sign ( one, dqm + dqp )
     2                   / max ( abs ( dqm + dqp ), tiny )


30           continue
c
c     2.  Choose time averaged, upwinded interface values.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
             do 40 i=ibeg-1,iend+1
               xi        = ( v1  (i,j,k) - vg1(i) ) * dt
               q1        = sign ( haf, xi )
               dtwid (i) = ( 0.5 + q1 ) * ( dlo(i-1,j,k)
     1                   + ( dx1a(i-1) - xi ) * dd   (i-1) )
     2                   + ( 0.5 - q1 ) * ( dlo(i  ,j,k)
     3                   - ( dx1a(i  ) + xi ) * dd   (i  ) )

               etwid (i) = ( 0.5 + q1 ) * ( eod(i-1,j,k)
     1                   + ( dx1a(i-1) - xi ) * deod (i-1) )
     2                   + ( 0.5 - q1 ) * ( eod(i  ,j,k)
     3                   - ( dx1a(i  ) + xi ) * deod (i  ) )


40           continue
c
c  For the purposes of consistent advection, construct the mass
c  flux across each 1-interface.  The mass flux will be used to create
c  the fluxes of all variables, including the momenta which are updated
c  in MOMX1.
c
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
           do 50 i=ibeg-1,iend+1
             mflux (i    ) = dtwid (i    ) * ( v1(i,j,k) - vg1(i) ) * dt
             dtwid (i    ) = mflux (i    ) * atwid (i    )

             etwid (i    ) = dtwid (i    ) * etwid (i    )


50         continue
c
c  Save the mass flux outside (ibeg:iend,jbeg:jend,kbeg:kend)
c  only for zones next to the inner borders.
c
           if ( (j.eq.js-1 .and. k.ge.kbeg)   .or.
     &          (j.ge.jbeg .and. k.eq.ks-1)   .or.
     &          (j.eq.js-1 .and. k.eq.ks-1) ) then
             if (ibeg.eq.is) mflx(is-1,j,k) = mflux (is-1)
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
             do 60 i=ibeg,iend
               mflx(i,j,k) = mflux (i      )
60           continue
             if (iend.eq.ie) mflx(ie+1,j,k) = mflux (ie+1)
           endif
c
c  Perform mass density and energy density advection.  Note that
c  the timestep "dt" is hidden the fluxes "dflx" and "eflx".
c  Do only zones inside (ibeg:iend,jbeg:jend,kbeg:kend).
c
           if (j.ge.jbeg .and. k.ge.kbeg) then
             if (ibeg.eq.is) mflx(is-1,j,k) = mflux (is-1)
CREMOVED FOR SPEC CPU2006 CDIR$ UNROLL 4
             do 80 i=ibeg,iend
             mflx(i,j,k)= mflux (i      )
             den(i,j,k) = ( dlo(i,j,k) * dvl1a(i)

     1                  - dtwid (i+1    ) + dtwid (i    ) ) * dvl1a i(i)


             e  (i,j,k) = ( e  (i,j,k) * dvl1a(i)

     1                  - etwid (i+1    ) + etwid (i    ) ) * dvl1a i(i)

c
c Compute e/d for the next substep.
c

             edn(i,j,k) = e(i,j,k) / den(i,j,k)



80         continue
           if (iend.eq.ie) mflx(ie+1,j,k) = mflux (ie+1)
         endif
90       continue
100    continue
c
       return
       end
c
c=======================================================================
c
c    \\\\\\\\\\        E N D   S U B R O U T I N E        //////////
c    //////////                T R A N X 1                \\\\\\\\\\
c
c=======================================================================
c
c

434-zeusmp

Exec Time : 2.833833e+10 cycles

Matching : 84.8%

__invivo__momx1_momx1__391

Real time: 1.252512e+09 -- Predicted time: 1.201426e+09

Callcount: 210

__invivo__forces_forces__466

Real time: 8.746841e+08 -- Predicted time: 8.774390e+08

Callcount: 180

__invivo__tranx2_tranx2__526

Real time: 9.854991e+08 -- Predicted time: 9.945085e+08

Callcount: 210

__invivo__hsmoc_hsmoc__1140

Real time: 1.816648e+09 -- Predicted time: 1.798875e+09

Callcount: 30

__invivo__hsmoc_hsmoc__780

Real time: 6.632617e+08 -- Predicted time: 6.707853e+08

Callcount: 30

__invivo__lorentz_lorentz__741

Real time: 7.646798e+08 -- Predicted time: 7.880262e+08

Callcount: 270

__invivo__momx3_momx3__401

Real time: 1.724225e+09 -- Predicted time: 2.004700e+09

Callcount: 510

__invivo__lorentz_lorentz__840

Real time: 1.688676e+09 -- Predicted time: 1.819827e+09

Callcount: 270

invivomomx1_momx1__391

invivoforces_forces__466

invivotranx2_tranx2__526

invivohsmoc_hsmoc__1140

invivohsmoc_hsmoc__780

invivolorentz_lorentz__741

invivomomx3_momx3__401

invivolorentz_lorentz__840