! Copyright 2008-2021 Earth Sciences Department, BSC-CNS
!
! This file is part of MONARCH.
!
! MONARCH is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! MONARCH is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with MONARCH. If not, see <http://www.gnu.org/licenses/>.
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
                        module module_bsc_dynamics_routines_chem
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!NMMB transport and boundary condition code adapted for MONARCH

!The NMMB code was developed by the National Oceanic and Atmospheric 
!Administration. NMMB is provided on an AS IS basis, without warranties
!or conditions of any kind, either express or implied.
 
!
use mpi

use module_kinds

use module_constants

use module_dm_parallel,only : looplimits

use module_my_domain_specs

use module_fltbnds,only: polehn,polewn,swaphn,swapwn

use module_bsc_chem_data,only : GC_BCCHEM_MAP

implicit none

integer(kind=kint),save :: &
 iunit_advec_sums

integer(kind=kint),save :: &
 jstart &
,jstop 

real(kind=kdbl) :: &
 btim

!-----------------
#ifdef ENABLE_SMP
!-----------------
integer(kind=kint) :: &
 nth &
,omp_get_num_threads &
,omp_get_thread_num &
,tid
 
external omp_get_num_threads,omp_get_thread_num
!------
#endif
!------

!
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
                        contains
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++                            
!-----------------------------------------------------------------------
                        subroutine hdiff_chem &
(global,hydro &
,inpes,jnpes,lm,lpt2 &
,dyh,rdyh &
,epsq2 &
,dxv,rare,rdxh &
,sice,sm &
,hdacx,hdacy,hdacvx,hdacvy &
,w,z &
!,cw,q,q2,t,u,v &
,q2,u,v &
!MONARCH
,num_tracers_chem &
,s &
!,kss,kse &
!MONARCH
!,def3d)
)
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
implicit none
!-----------------------------------------------------------------------
real(kind=kfpt),parameter:: &
 defvfc=2. &                 ! vertical deformation weight
,scq2=50. &                  ! 2tke weighting factor
,epsq=1.e-20 &               ! floor value for specific humidity
,slopec=.05                  ! critical slope
           
!-----------------------------------------------------------------------
logical(kind=klog),intent(in):: &
 global &                    ! global or regional
,hydro                       ! logical switch for nonhydrostatic dynamics
           
integer(kind=kint),intent(in):: &
 inpes &                     ! w-e # of subdomains
,jnpes &                     ! n-s # of subdomains
,lm &                        ! total # of levels
,lpt2                        ! # of levels in the pressure range

real(kind=kfpt),intent(in):: &
 dyh &                       !
,rdyh                        ! 1/deltay
 
real(kind=kfpt),dimension(1:lm),intent(in):: &
 epsq2                       ! floor value of 2tke

real(kind=kfpt),dimension(jds:jde),intent(in):: &
 dxv &                       !
,rare &                      !
,rdxh                        ! 1/deltax
           
real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: &
 hdacx &                     ! exchange coefficient for mass points
,hdacy &                     ! exchange coefficient for mass points
,hdacvx &                    ! exchange coefficient for velocity points
,hdacvy &                    ! exchange coefficient for velocity points
,sice &                      ! sea-ice mask
,sm                          ! sea mask
           
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: &
 w &                         ! w wind component
,z                           ! height at mass points
           
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: &
!real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout):: &
! cw &                        ! condensate
!,q &                         ! specific humidity
 q2 &                        ! 2tke
!,t &                         ! temperature
,u &                         ! u wind component
,v                           ! v wind component

!real(kind=kfpt),dimension(ims:ime,jms:jme,lm),intent(out) :: &
! def3d   !defined below       
!MONARCH
!
integer(kind=kint),intent(in):: &
! kss &                       ! start index of aerosol/gas in tracer array
!,kse &                       ! end index of tracer array
 num_tracers_chem            ! number of aerosol/gas tracers to diffuse

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:max(1,num_tracers_chem)),intent(inout):: &
 s                               ! aerosol/gas tracer array
!
!MONARCH           
!-----------------------------------------------------------------------
!--local variables------------------------------------------------------
!-----------------------------------------------------------------------
logical(kind=klog):: &
 cilinx &                    ! coast/ice line
,ciliny                      ! coast/ice line
 
integer(kind=kint):: &
 i &                         ! index in x direction
,j &                         ! index in y direction
,l                           ! index in p direction
           
real(kind=kfpt):: &
 def1 &                      ! component of deformation
,def2 &                      ! component of deformation
,def3 &                      ! component of deformation
,def4 &                      ! component of deformation
,defc &                      ! deformation floor
,defm &                      ! deformation cap
,defp &                      ! deformation at the point
,defs &                      ! component of deformation
,deft &                      ! component of deformation
,defvp &
,defhp &
,facdif &                    ! diffusion factor
,hkfx &                      ! def with slope factor
,hkfy &                      ! def with slope factor
,q2trm &                     !
,slopx &                     ! x slope
,slopy                       ! y slope

real(kind=kfpt),dimension(ims:ime,jms:jme):: &
 cdif &                      ! condensate 2nd order diffusion
,cx &                        ! condensate difference, x direction
,cy &                        ! condensate difference, y direction
,def &                       ! deformation (in halo exchange)
,fmlx &                      ! x slope mask
,fmly &                      ! y slope mask
,hkx &                       ! deformation sum, x direction
,hky &                       ! deformation sum, y direction
,qdif &                      ! specific humidity 2nd order diffusion
,qx &                        ! specific humidity difference, x direction
,qy &                        ! specific humidity difference, y direction
,q2dif &                     ! 2tke 2nd order diffusion
,q2x &                       ! 2tke difference, x direction
,q2y &                       ! 2tke difference, y direction
,tdif &                      ! temperature 2nd order diffusion
,tx &                        ! temperature difference, x direction
,ty &                        ! temperature difference, y direction
,udif &                      ! u wind component 2nd order diffusion
,ux &                        ! u wind component difference, x direction
,uy &                        ! u wind component difference, y direction
,vdif &                      ! v wind component 2nd order diffusion
,vx &                        ! v wind component difference, x direction
,vy                          ! v wind component difference, y direction
!MONARCH
real(kind=kfpt),dimension(ims:ime,jms:jme,lm) :: &
 def3d  
integer(kind=kint):: &
 ks                          ! aerosol/chem index

real(kind=kfpt),dimension(ims:ime,jms:jme,1:max(1,num_tracers_chem)):: &
 sdif &                      ! aerosol/chem 2nd order diffusion
,sx &                        ! aerosol/chem difference, x direction
,sy                          ! aerosol/chem difference, y direction
!MONARCH
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
      if(global) then
        defm=1.6875e-4 ! 1.35e-3/2./4. ! deformation cap, /4. for smag2=0.4
        facdif=1.0
      else
        defm=9999.
        facdif=4.0   !bsf: was 4.0 in 10/18/2011 NAM implementation
      endif
!-----------------------------------------------------------------------
!
      do l=1,lm
       if(s_bdy)then
         do i=ims,ime
           def3d(i,jds,l)=0.
         enddo
       endif
!
       if(n_bdy)then
         do i=ims,ime
           def3d(i,jde,l)=0.
         enddo
       endif
!
       if(w_bdy)then
         do j=jms,jme
           def3d(ids,j,l)=0.
         enddo
       endif
!
       if(e_bdy)then
         do j=jms,jme
           def3d(ide,j,l)=0.
         enddo
       endif
     enddo
!
!-----------------------------------------------------------------------
!---grand vertical loop-------------------------------------------------
!-----------------------------------------------------------------------
!
!.......................................................................
!$omp parallel do &
!$omp private(def1,def2,def3,def4,defc,defp,defs,deft,i,j,l,q2trm)
!.......................................................................
!-----------------------------------------------------------------------
!
      vertical_loop_1: do l=1,lm
!
!-----------------------------------------------------------------------
        if(global)then
          if(l.gt.lpt2/3) then
            defc=0.
          else
            defc=defm*0.01
          endif
        else ! regional
          if (l.le.3) then
!MONARCH2   defc=0.015*(3-l+1.)/3. !To avoid problems in so4 at the top
            defc=0.               
!OJORBA8
          else
            defc=0.
          endif
        endif
!-----------------------------------------------------------------------
!        do j=jts_h1,jte_h2
!          do i=its_h1,ite_h2
!            q2(i,j,l)=max(q2(i,j,l),epsq2)
!          enddo
!        enddo
!-----------------------------------------------------------------------
        do j=jts_b1_h1,jte_b1_h2
          do i=its_b1_h1,ite_b1_h2
            deft=((u(i  ,j-1,l)+u(i  ,j  ,l) &
                  -u(i-1,j-1,l)-u(i-1,j  ,l))*dyh &
                 -(v(i-1,j  ,l)+v(i  ,j  ,l))*dxv(j  ) &
                 +(v(i-1,j-1,l)+v(i  ,j-1,l))*dxv(j-1))*rare(j)
            defs=((u(i-1,j  ,l)+u(i  ,j  ,l))*dxv(j  ) &
                 -(u(i-1,j-1,l)+u(i  ,j-1,l))*dxv(j-1) &
                 +(v(i  ,j-1,l)+v(i  ,j  ,l) &
                  -v(i-1,j-1,l)-v(i-1,j  ,l))*dyh     )*rare(j)
!            defz=(-(u(i-1,j  ,l)+u(i  ,j  ,l))*dxv(j  ) &
!                  +(u(i-1,j-1,l)+u(i  ,j-1,l))*dxv(j-1) &
!                  +(v(i  ,j-1,l)+v(i  ,j  ,l) &
!                   -v(i-1,j-1,l)-v(i-1,j  ,l))*dyh     )*rare(j)  *10.
!            if(defz.gt.0.) defz=0.
!
            if(.not.hydro) then
              def1=(w(i,j,l)-w(i,j-1,l))*rdyh
              def2=(w(i,j,l)-w(i-1,j,l))*rdxh(j)
              def3=(w(i+1,j,l)-w(i,j,l))*rdxh(j)
              def4=(w(i,j+1,l)-w(i,j,l))*rdyh
            else
              def1=0.
              def2=0.
              def3=0.
              def4=0.
            endif

            if(q2(i,j,l).gt.epsq2(L)) then
              q2trm=scq2*q2(i,j,l)*rare(j)
            else
              q2trm=0.
            endif


            defhp=deft*deft+defs*defs+q2trm
            defvp=def1*def1+def2*def2+def3*def3+def4*def4 
!
            defp=sqrt(defhp*2.+defvp*defvfc)
            defp=max (defp,defc)
            defp=min (defp,defm)
!
            def3d(i,j,l)=defp
          enddo
        enddo
!-----------------------------------------------------------------------
!
      enddo vertical_loop_1
!.......................................................................
!$omp end parallel do
!.......................................................................
!
!-----------------------------------------------------------------------
!
      if(global) then
!        btim=timef()
        call swaphn(def3d,ims,ime,jms,jme,lm,inpes)
!        timers(my_domain_id)%swaphn_tim=timers(my_domain_id)%swaphn_tim+(timef()-btim)
!
!        btim=timef()
        call polehn(def3d,ims,ime,jms,jme,lm,inpes,jnpes)
!        timers(my_domain_id)%polehn_tim=timers(my_domain_id)%polehn_tim+(timef()-btim)
      endif
!
!-----------------------------------------------------------------------
!.......................................................................
!$omp parallel do &
!$omp private(cdif,cilinx,ciliny,cx,cy,fmlx,fmly, &
!$omp         hkfx,hkfy,hkx,hky,i,j,l, &
!$omp         q2dif,q2x,q2y,qdif,qx,qy,slopx,slopy, &
!$omp         tdif,tx,ty,udif,ux,uy,vdif,vx,vy)
!.......................................................................
!-----------------------------------------------------------------------
      vertical_loop_3: do l=1,lm
!-----------------------------------------------------------------------
        if(l.gt.lpt2.and..not.hydro) then
          do j=jts_b1,jte_h2
            do i=its_b1,ite_h2
              cilinx=sice(i-1,j).ne.sice(i,j) &
                 .or.sm  (i-1,j).ne.sm  (i,j)
              ciliny=sice(i,j-1).ne.sice(i,j) &
                 .or.sm  (i,j-1).ne.sm  (i,j)
              slopx=abs((z(i,j,l)-z(i-1,j,l))*rdxh(j))
              slopy=abs((z(i,j,l)-z(i,j-1,l))*rdyh   )
!
              if(slopx.le.slopec.or.cilinx) then
                fmlx(i,j)=1.
              else
                fmlx(i,j)=0.
              endif
!
              if(slopy.le.slopec.or.ciliny) then
                fmly(i,j)=1.
              else
                fmly(i,j)=0.
              endif
!
            enddo
          enddo
        else
          do j=jts_b1,jte_h2
            do i=its_b1,ite_h2
              fmlx(i,j)=1.
              fmly(i,j)=1.
            enddo
          enddo
        endif
!-----------------------------------------------------------------------
!---contributions behind mass points------------------------------------
!-----------------------------------------------------------------------
!        do j=jts_b1,jte_h2
!          do i=its_b1,ite_h2
!            hkx(i,j)=(def3d(i-1,j,l)+def3d(i,j,l))
!            hky(i,j)=(def3d(i,j-1,l)+def3d(i,j,l))
!            hkfx=hkx(i,j)*fmlx(i,j)
!            hkfy=hky(i,j)*fmly(i,j)
!
!            tx (i,j)=(t (i,j,l)-t (i-1,j,l))*hkfx
!            qx (i,j)=(q (i,j,l)-q (i-1,j,l))*hkfx
!            cx (i,j)=(cw(i,j,l)-cw(i-1,j,l))*hkfx
!            q2x(i,j)=(q2(i,j,l)-q2(i-1,j,l))*hkfx
!
!            ty (i,j)=(t (i,j,l)-t (i,j-1,l))*hkfy
!            qy (i,j)=(q (i,j,l)-q (i,j-1,l))*hkfy
!            cy (i,j)=(cw(i,j,l)-cw(i,j-1,l))*hkfy
!            q2y(i,j)=(q2(i,j,l)-q2(i,j-1,l))*hkfy
!MONARCH
!
!            if(num_tracers_chem>0.and.diff_chem)then
!             do ks=1,num_tracers_chem
!               sx (i,j,ks)=(s (i,j,l,ks)-s (i-1,j,l,ks))*hkfx
!               sy (i,j,ks)=(s (i,j,l,ks)-s (i,j-1,l,ks))*hkfy
!             enddo
!            endif
!
!MONARCH
!          enddo
!        enddo
!MONARCH
! NEW IMPLEMENTATION, 30% FASTER
       if(num_tracers_chem>0)then
       do ks=1,num_tracers_chem
        do j=jts_b1,jte_h2
         do i=its_b1,ite_h2
               hkx(i,j)=(def3d(i-1,j,l)+def3d(i,j,l))
               hky(i,j)=(def3d(i,j-1,l)+def3d(i,j,l))
               hkfx=hkx(i,j)*fmlx(i,j)
               hkfy=hky(i,j)*fmly(i,j)
               sx (i,j,ks)=(s (i,j,l,ks)-s (i-1,j,l,ks))*hkfx
               sy (i,j,ks)=(s (i,j,l,ks)-s (i,j-1,l,ks))*hkfy
          enddo
         enddo
        enddo
       endif
!MONARCH
!-----------------------------------------------------------------------
!---u,v, contributions, behind v points---------------------------------
!-----------------------------------------------------------------------
!        do j=jts_b1,jte_b1_h1
!          do i=its_b1,ite_b1_h1
!            ux(i,j)=(u(i,j,l)-u(i-1,j,l))*hky(i,j+1)
!            vx(i,j)=(v(i,j,l)-v(i-1,j,l))*hky(i,j+1)
!            uy(i,j)=(u(i,j,l)-u(i,j-1,l))*hkx(i+1,j)
!            vy(i,j)=(v(i,j,l)-v(i,j-1,l))*hkx(i+1,j)
!          enddo
!        enddo
!-----------------------------------------------------------------------
!        do j=jts_b1,jte_b1
!          do i=its_b1,ite_b1
!            tdif (i,j)=(tx (i+1,j)-tx (i,j))*hdacx(i,j) &
!                      +(ty (i,j+1)-ty (i,j))*hdacy(i,j)
!            qdif (i,j)=(qx (i+1,j)-qx (i,j))*hdacx(i,j) &
!                      +(qy (i,j+1)-qy (i,j))*hdacy(i,j)
!            cdif (i,j)=(cx (i+1,j)-cx (i,j))*hdacx(i,j) &
!                      +(cy (i,j+1)-cy (i,j))*hdacy(i,j)
!            q2dif(i,j)=(q2x(i+1,j)-q2x(i,j))*hdacx(i,j) &
!                      +(q2y(i,j+1)-q2y(i,j))*hdacy(i,j)
!          enddo
!        enddo
!MONARCH
       if(num_tracers_chem>0)then
!
        do ks=1,num_tracers_chem
         do j=jts_b1,jte_b1
           do i=its_b1,ite_b1
              if(global)then
!!!!IMPLEMENTATION TO AVOID HDIFF PROBLEMS
                 sdif (i,j,ks)=(sx (i+1,j,ks)-sx (i,j,ks))*hdacx(i,j)/(dyh*max(1/rdxh(j),dyh))*min(1/rdxh(j),dyh)*min(1/rdxh(j),dyh) &
                              +(sy (i,j+1,ks)-sy (i,j,ks))*hdacy(i,j)/(dyh*max(1/rdxh(j),dyh))*min(1/rdxh(j),dyh)*min(1/rdxh(j),dyh)
                 if(l.le.5)then
                   sdif (i,j,ks)=sdif (i,j,ks)*0.01*(6-l)
                 endif
!!!!IMPLEMENTATION TO AVOID HDIFF PROBLEMS END
              else
!REGIONAL reducing hdiff towards the top layers
                 sdif (i,j,ks)=(sx (i+1,j,ks)-sx (i,j,ks))*hdacx(i,j) &
                              +(sy (i,j+1,ks)-sy (i,j,ks))*hdacy(i,j)
               endif
             enddo
           enddo
         enddo
!
       endif
!
!MONARCH
!-----------------------------------------------------------------------
!        do j=jts_b1,jte_b2
!          do i=its_b1,ite_b2
!            udif(i,j)=(ux(i+1,j)-ux(i,j))*hdacvx(i,j) &
!                     +(uy(i,j+1)-uy(i,j))*hdacvy(i,j)
!            vdif(i,j)=(vx(i+1,j)-vx(i,j))*hdacvx(i,j) &
!                     +(vy(i,j+1)-vy(i,j))*hdacvy(i,j)
!          enddo
!        enddo
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!-------------2-nd order diffusion--------------------------------------
!-----------------------------------------------------------------------
!          do j=jts_b1,jte_b1
!            do i=its_b1,ite_b1
!              t (i,j,l)=t (i,j,l)+tdif (i,j)
!-- Enhanced diffusion for Q & CWM (doubling smag2 = 4X diffusion)
!              q (i,j,l)=q (i,j,l)+facdif*qdif (i,j)
!              cw(i,j,l)=cw(i,j,l)+facdif*cdif (i,j)
!              q2(i,j,l)=q2(i,j,l)+q2dif(i,j)
!            enddo
!          enddo
!          do j=jts_b1,jte_b2
!            do i=its_b1,ite_b2
!              u(i,j,l)=u(i,j,l)+udif(i,j)
!              v(i,j,l)=v(i,j,l)+vdif(i,j)
!            enddo
!          enddo
!MONARCH
!
         if(num_tracers_chem>0)then
!
         do ks=1,num_tracers_chem !FASTER
           do j=jts_b1,jte_b1
             do i=its_b1,ite_b1
!               do ks=1,num_tracers_chem
!-- Enhanced diffusion for TRACERS MIMIC Q & CWM (doubling smag2 = 4X diffusion)
                 s (i,j,l,ks)=s (i,j,l,ks)+facdif*sdif (i,j,ks)
!MONARCH
                 if(s(i,j,l,ks)<0.)then
!                   print *,'problems hdiff',i,j,l,ks,s(i,j,l,ks)
                   s(i,j,l,ks)=1.e-20
                 endif
!MONARCH
               enddo
             enddo
           enddo
!
         endif
!
!MONARCH
!-----------------------------------------------------------------------
!
        enddo vertical_loop_3
!.......................................................................
!$omp end parallel do
!.......................................................................
!
!-----------------------------------------------------------------------
!
                        endsubroutine hdiff_chem
!
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
!*** adv2_chem is similar to adv2 but including sedimentation for aerosol
!*** advective timestep for aerosol/chem can be set up differently than
!*** for met tracers in the configure file
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
                        subroutine adv2_chem &
(global &
,idtadt,kss,kse,lm,lnsad &
,dt,rdyh &
,dsg2,pdsg1 &
,fah,rdxh &
,pd,pdo &
,psgdt &
,up,vp &
,s,sp &               !!!chem and chem_prev
!
!,q2,indx_q2 &
!
,t,q,psgml1,sgml2 &          
,adv_chem,sedim &            
,num_aero,num_gas &          
,rho_aero,r_aero_v,r_aero_e &
!
!
!---temporary arguments-------------------------------------------------
,pfne,pfnw,pfx,pfy &
,s1,tcs)              !!!chem_sqrt and chem_tend
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
implicit none
!-----------------------------------------------------------------------
real(kind=kfpt),parameter:: &
 cfc=1.533 &                 ! adams-bashforth positioning in time
,bfc=1.-cfc &                ! adams bashforth positioning in time
!MONARCH
,epstracer=0. & !1e-20 & !1e-15 &
!MONARCH
,epsq=1.e-20 &               ! floor value for specific humidity
,epsq2=0.02 &                ! floor value for 2tke
,pfc=1.+4./6. &              ! 4th order momentum advection
,sfc=-1./6. &                ! 4th order momentum advection
,epscm=2.e-6 &               ! a floor value (not used)
,w1=1.0 &                    ! crank-nicholson uncentering
!,w1=0.80 &                   ! crank-nicholson uncentering
,w2=2.-w1                    ! crank-nicholson uncentering

!
real(kind=kfpt),parameter :: &
 kb=1.3806504e-23 &          !<-- kb: boltzmann 1.3806504E-23 J/K (= kg*m**2/s**2/K)
,wtair=28.966e-3 &           !<-- wtair: molecular weight of air (kg/mol)
,avg=6.02252e+23 &           !<-- avg: avogadro's number (molec. mol-1)
,viscos= 1.718e-5 &          !<-- viscos: dynamic viscosity of air (=1.718E-5 kg/m/s)
,rgas= 286.9
!

logical(kind=klog),intent(in):: &
 global

integer(kind=kint),intent(in):: &
 idtadt &                    !
,kse &                       ! terminal species index
,kss &                       ! initial species index
,lm &                        ! total # of levels
,lnsad                      !

real(kind=kfpt),intent(in):: &
 dt &                        ! dynamics time step
,rdyh                        !

real(kind=kfpt),dimension(1:lm),intent(in):: &
 dsg2 &                      ! delta sigmas
,pdsg1                       ! delta pressures

real(kind=kfpt),dimension(jds:jde),intent(in):: &
 fah &                       ! grid factor
,rdxh                        !

real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: &
 pd &                        ! sigma range pressure difference
,pdo                         ! sigma range pressure difference

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1),intent(in):: &
 psgdt                       ! vertical mass flux

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(in):: &
 up &                        !
,vp                          !

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:max(1,kse)),intent(inout):: &
 s &                         ! tracers
,sp                          ! s at previous time level

!---temporary arguments-------------------------------------------------
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: &
 pfne &                      ! mass flux, ne direction
,pfnw &                      ! mass flux, nw direction
,pfx &                       ! mass flux, x direction
,pfy                         ! mass flux, y direction

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:max(1,kse)),intent(inout):: &
 s1 &                        ! intermediate value of sqrt(s)
,tcs                         ! timechange of s

!
!
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm),intent(inout) :: &
 t &                           !<-- temperature
,q                             !<-- specific humidity
 
real(kind=kfpt),dimension(1:lm),intent(in) :: &
 psgml1 &                      !<-- Pressure at midlevels 
,sgml2                         !<-- Sigma at midlevels

logical(kind=klog),intent(in) :: &
 adv_chem &                  !<-- Logical switch: will tracers be advected?
,sedim                       !<-- Logical switch: apply sedimentation?

integer(kind=kint),intent(in) :: &
 num_aero &                  !<-- # of aerosol transport bins
,num_gas                     !<-- # of gas species

real(kind=kfpt),dimension(1:max(1,num_aero)),intent(in) :: &
 rho_aero &                  !<-- aerosol bin densities (kg/m3) 
,r_aero_v &                  !<-- aerosol bin volume radii (m)
,r_aero_e                    !<-- aerosol bin effective radii (m)
!
!MONARCH                   
!
!--local variables------------------------------------------------------
integer(kind=kint):: &       
 i &                         !
,iap &                       !
,ibeg &                      !
,iend &                      !
,j &                         !
,jap &                       !
,jbeg &                      !
,jend &                      !
,ks &                        !
,l                           !

real(kind=kfpt):: &
 cf &                        ! temporary
,cms &                       ! temporary
,dtq &                       ! dt/4
,emhp &                      !
,enhp &                      !
,fahp &                      ! temporary grid factor
,pp &                        !
,qq &                        !
,rdp &                       ! 1/deltap
,vvlo &                      ! vertical velocity, lower interface
,vvup &                      ! vertical velocity, upper interface
,pvvup                       ! vertical mass flux, upper interface

real(kind=kfpt),dimension(ims:ime,jms:jme):: &
 pdop &                      ! hydrostatic pressure difference at v points
,pvvlo &                     ! vertical mass flux, lower interface
,ss1 &                       ! extrapolated species between time levels
,ssne &                      ! flux, ne direction
,ssnw &                      ! flux, nw direction
,ssx &                       ! flux, x direction
,ssy                         ! flux, y direction

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: &
 crs &                       ! vertical advection temporary
,rcms                        ! vertical advection temporary

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:kse):: &
 rsts                        ! vertical advection temporary
!
!MONARCH
!
real(kind=kfpt),dimension(ims:ime,jms:jme,kss:max(1,kse)) :: &
 pvvlo_new                   !<-- vertical mass flux (with sedimentation), lower interface

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:max(1,kse)) :: &
 crs_new &                   !<-- vertical advection temporary (with sedimentation)
,rcms_new                    !<-- vertical advection temporary (with sedimentation)

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm-1,kss:max(1,kse)) :: &
 psgdt_new                   !<-- vertical mass flux (with sedimentation) of aerosol

real(kind=kfpt) :: &
 dum &                       !<-- dum parameter
,viscosk &                   !<-- kinematic viscosity = viscos/rho = (m**2/s)
,vthermg &                   !<-- mean thermal velocity of air molecules (m/s)
,freemp &                    !<-- mean free path of an air molecule
                             !<-- =2x viscosk/thermal vel. of air molecules (m)
,cc &                        !<-- Cunningham Slip Factor
,vterm &                     !<-- Terminal velocity of particles (m/s)
,rho_i &                     !<-- air density at interfaces(kg/m3)
,temp                        !<-- temperature (K)

real(kind=kfpt),dimension(1:lm) :: &
rho                          !<-- air density at midlevels(kg/m3)

!
!MONARCH

!-----------------           
!#ifdef ENABLE_SMP            
!!-----------------           
!integer(kind=kint) :: &      
! jstart &                    
!,jstop &                     
!,nth &
!,omp_get_num_threads &
!,omp_get_thread_num &        
!,tid
!!-----------------           
!#else 
!!-----------------           
!integer(kind=kint) :: &      
! jstart &                    
!,jstop
!!-----------------
!#endif                       
!-----------------           
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
!
!-----------------
#ifdef ENABLE_SMP
!-----------------
!.......................................................................
!$omp parallel private(i,j,jstart,jstop,ks,l,nth,tid)
!.......................................................................
      nth = omp_get_num_threads()
      tid = omp_get_thread_num()
      call looplimits(tid, nth, jts_h1, jte_h1, jstart, jstop)
!-----------------
#else
!-----------------
      jstart = jts_h1
      jstop  = jte_h1        
!-----------------           
#endif
!-----------------           
      do ks=kss,kse          
        do l=1,lm            
          do j=jstart,jstop  
            do i=its_h1,ite_h1
!MONARCH
!              s(i,j,l,ks)=max(s(i,j,l,ks),epsq)
              s(i,j,l,ks)=max(s(i,j,l,ks),epstracer)
!MONARCH
            enddo
          enddo
        enddo                
      enddo
!
        do l=1,lm
          do j=jstart,jstop
            do i=its_h1,ite_h1
              q  (i,j,l)=max(q  (i,j,l),epsq)
            enddo
          enddo
        enddo
!-----------------------------------------------------------------------
      do ks=kss,kse ! loop by species
!-----------------------------------------------------------------------
        do l=1,lm
          do j=jstart,jstop
            do i=its_h1,ite_h1
              s1(i,j,l,ks)=sqrt(s(i,j,l,ks))

!MONARCH: inititalize tcs
              tcs(i,j,l,ks)=0.
              rsts(i,j,l,ks)=0.
!MONARCH
            enddo
          enddo
        enddo
!-----------------------------------------------------------------------
!
      enddo ! end of the loop by species
!
!-----------------
#ifdef ENABLE_SMP
!-----------------
!.......................................................................
!$omp end parallel
!.......................................................................
!-----------------
#endif
!-----------------
!-----------------------------------------------------------------------
!-----------------
#ifdef ENABLE_SMP
!-----------------
!.......................................................................
!$omp parallel private(cf,cms,dtq,i,j,jstart,jstop,l,nth,pvvup,rdp, &
!$omp                  tid,vvlo,vvup)
!.......................................................................
      nth = omp_get_num_threads()
      tid = omp_get_thread_num()
      call looplimits(tid, nth, jts_b1, jte_b1, jstart, jstop)
!-----------------
#else
!-----------------
      jstart = jts_b1
      jstop  = jte_b1
!-----------------
#endif
!-----------------
      do j=jstart,jstop
        do i=its_b1,ite_b1
          pdop(i,j)=(pd(i,j)+pdo(i,j))*0.5
        enddo
      enddo
!
!MONARCH
!-----------------------------------------------------------------------
!***  Sedimentation in the bottom layer to the ground (lm) is performed 
!***  in the physics (dry dep) together with turbulent mix-out.
!-----------------------------------------------------------------------
!***  terminal vel. of particles is included in the vertical mass flux
!***  Preparations for aerosols follow
!-----------------------------------------------------------------------
!             
!psgdt is 0 at the top of the atmosphere and the surface
!psgdt(1) is the second interface starting from the top!!!!!! 
            
      if(num_aero>0.and.sedim)then                                      !!! for aerosol with sedimentation
!       
        do l=1,lm-1
!        do l=3,lm-1
          do j=jstart,jstop
            do i=its_b1,ite_b1
!
            rho(l)=(sgml2(l)*pd(i,j)+psgml1(l))/(r_d*t(i,j,l)*(p608*q(i,j,l)+1.))
            rho(l+1)=(sgml2(l+1)*pd(i,j)+psgml1(l+1))/(r_d*t(i,j,l+1)*(p608*q(i,j,l+1)+1.))
!
!
              rho_i=(rho(l)+rho(l+1))*0.5
              temp =(t(i,j,l)+t(i,j,l+1))*0.5
!
              viscosk = viscos/rho_i
              vthermg = sqrt(8.*kb*temp*avg/(3.1416*wtair))
              freemp  = 2.0*viscosk/vthermg
!
!-----------------------------------------------------------------------
              do ks=kss,num_aero                    !!! loop by aerosols
!-----------------------------------------------------------------------
!
!corr                cc   = 1.+((2.*freemp/r_aero_e(ks))                  &  !!we use effective radius for cunningham
!corr                       *(1.257+0.4*exp(-0.55*r_aero_e(ks)/freemp)))
                cc   = 1.+((freemp/r_aero_e(ks))                  &  !!we use effective radius for cunningham
                       *(1.257+0.4*exp(-1.1*r_aero_e(ks)/freemp)))
!
                vterm= (r_aero_v(ks)*2.)**2*(rho_aero(ks)-rho_i)*g*cc  &  !!density is in kg/m3 in contrast to g/cm3 in previous version
                       /(18.*viscos)                                        !!we use volume radius for terminal velocity
!
               if(adv_chem)then
!
                  psgdt_new(i,j,l,ks)=-vterm*g*rho_i+psgdt(i,j,l)            !!sedimentation and vertical advection        
                else
                  psgdt_new(i,j,l,ks)=-vterm*g*rho_i                         !!only sedimentation .... for testing
!
                endif
!
!----------------------------------------------------------------------
              enddo                            !!! end loop by aerosols
!----------------------------------------------------------------------
!
          enddo
        enddo
      enddo
!
    endif                                            !!endif aerosol
!
    if (num_aero>0.and..not.sedim)then              !!in this case adv_chem is true by force (see if-endif when calling the subroutine)
       do l=1,lm-1
!        do l=3,lm-1
          do j=jstart,jstop
            do i=its_b1,ite_b1
             do ks=kss,num_aero
              psgdt_new(i,j,l,ks)=psgdt(i,j,l)                          !!only vertical advection ... for testing
             enddo
            enddo
          enddo
        enddo
     endif
!             
!-----------------------------------------------------------------------
!---crank-nicholson vertical advection for gases -----------------------
!-----------------------------------------------------------------------

      if(num_gas>0.and.adv_chem)then                       !!! gas vertical advection
                       
      dtq=dt*0.25*idtadt
      do j=jstart,jstop
        do i=its_b1,ite_b1
          pvvlo(i,j)=psgdt(i,j,1)*dtq
          vvlo=pvvlo(i,j)/(dsg2(1)*pdop(i,j)+pdsg1(1))
          cms=-vvlo*w2+1.
          rcms(i,j,1)=1./cms
          crs(i,j,1)=vvlo*w2
!
          do ks=kss+num_aero,kse                           !!! loop by gases 
            rsts(i,j,1,ks)=(-vvlo*w1) &
                          *(s1(i,j,2,ks)-s1(i,j,1,ks)) &
                          +s1(i,j,1,ks)
          enddo
        enddo
      enddo
      do l=2,lm-1
        do j=jstart,jstop
          do i=its_b1,ite_b1
            rdp=1./(dsg2(l)*pdop(i,j)+pdsg1(l))
            pvvup=pvvlo(i,j)
            pvvlo(i,j)=psgdt(i,j,l)*dtq
!
            vvup=pvvup*rdp
            vvlo=pvvlo(i,j)*rdp
!
            cf=-vvup*w2*rcms(i,j,l-1)
            cms=-crs(i,j,l-1)*cf+((vvup-vvlo)*w2+1.)
            rcms(i,j,l)=1./cms
            crs(i,j,l)=vvlo*w2
!
            do ks=kss+num_aero,kse                          !!! loop by gases
              rsts(i,j,l,ks)=-rsts(i,j,l-1,ks)*cf+s1(i,j,l,ks) &
                             -(s1(i,j,l  ,ks)-s1(i,j,l-1,ks))*vvup*w1 &
                             -(s1(i,j,l+1,ks)-s1(i,j,l  ,ks))*vvlo*w1
            enddo
          enddo
        enddo
      enddo
      do j=jstart,jstop
        do i=its_b1,ite_b1
          pvvup=pvvlo(i,j)
          vvup=pvvup/(dsg2(lm)*pdop(i,j)+pdsg1(lm))
!
          cf=-vvup*w2*rcms(i,j,lm-1)
          cms=-crs(i,j,lm-1)*cf+(vvup*w2+1.)
          rcms(i,j,lm)=1./cms
          crs(i,j,lm)=0.
!
          do ks=kss+num_aero,kse                           !!! loop by gases
            rsts(i,j,lm,ks)=-rsts(i,j,lm-1,ks)*cf+s1(i,j,lm,ks) &
                           -(s1(i,j,lm,ks)-s1(i,j,lm-1,ks))*vvup*w1
!
            tcs(i,j,lm,ks)=rsts(i,j,lm,ks)*rcms(i,j,lm)-s1(i,j,lm,ks)
          enddo
        enddo
      enddo
      do ks=kss+num_aero,kse                               !!! loop by gases
        do l=lm-1,1,-1
          do j=jstart,jstop
            do i=its_b1,ite_b1
              tcs(i,j,l,ks)=(-crs(i,j,l)*(s1(i,j,l+1,ks)+tcs(i,j,l+1,ks)) &
                             +rsts(i,j,l,ks)) &
                           *rcms(i,j,l)-s1(i,j,l,ks)
            enddo
          enddo
        enddo
      enddo

     endif   !! gas vertical advection
!
!-----------------------------------------------------------------------
!---crank-nicholson vertical advection and sedimentation----------------
!-----------------------------------------------------------------------

      if(num_aero>0)then                     !!! aerosol vertical advection and/or sedimentation 
!
!
      dtq=dt*0.25*idtadt
            
      do ks=kss,num_aero                                          !!! only aerosol
       do j=jstart,jstop
         do i=its_b1,ite_b1
!            pvvlo(i,j)=psgdt(i,j,1)*dtq                    
!           pvvlo_new(i,j,ks)=psgdt_new(i,j,3,ks)*dtq
           pvvlo_new(i,j,ks)=psgdt_new(i,j,1,ks)*dtq
!           pvvlo_new(i,j,ks)=psgdt(i,j,1)*dtq
           vvlo=pvvlo_new(i,j,ks)/(dsg2(1)*pdop(i,j)+pdsg1(1))
!           vvlo=pvvlo_new(i,j,ks)/(dsg2(3)*pdop(i,j)+pdsg1(3))
           cms=-vvlo*w2+1.
           rcms_new(i,j,1,ks)=1./cms
!           rcms_new(i,j,3,ks)=1./cms
           crs_new(i,j,1,ks)=vvlo*w2
!           crs_new(i,j,3,ks)=vvlo*w2
!         
           rsts(i,j,1,ks)=(-vvlo*w1) &
                          *(s1(i,j,2,ks)-s1(i,j,1,ks)) &
                          +s1(i,j,1,ks)
!           rsts(i,j,3,ks)=(-vvlo*w1) &
!                          *(s1(i,j,4,ks)-s1(i,j,3,ks)) &
!                          +s1(i,j,3,ks)
          enddo
        enddo
      enddo                
      do l=2,lm-1
!      do l=4,lm-1
        do j=jstart,jstop
          do i=its_b1,ite_b1
            rdp=1./(dsg2(l)*pdop(i,j)+pdsg1(l))
!     
            do ks=kss,num_aero                                    !!! only aerosol
             pvvup=pvvlo_new(i,j,ks)
             pvvlo_new(i,j,ks)=psgdt_new(i,j,l,ks)*dtq
!           
             vvup=pvvup*rdp
             vvlo=pvvlo_new(i,j,ks)*rdp
!                          
             cf=-vvup*w2*rcms_new(i,j,l-1,ks)
             cms=-crs_new(i,j,l-1,ks)*cf+((vvup-vvlo)*w2+1.)
             rcms_new(i,j,l,ks)=1./cms
             crs_new(i,j,l,ks)=vvlo*w2
!
             rsts(i,j,l,ks)=-rsts(i,j,l-1,ks)*cf+s1(i,j,l,ks) &
                            -(s1(i,j,l  ,ks)-s1(i,j,l-1,ks))*vvup*w1 &
                            -(s1(i,j,l+1,ks)-s1(i,j,l  ,ks))*vvlo*w1
            enddo
          enddo
        enddo
      enddo
      do ks=kss,num_aero                                        !!! only aerosol
       do j=jstart,jstop
         do i=its_b1,ite_b1
           pvvup=pvvlo_new(i,j,ks)
           vvup=pvvup/(dsg2(lm)*pdop(i,j)+pdsg1(lm))
!
           cf=-vvup*w2*rcms_new(i,j,lm-1,ks)
           cms=-crs_new(i,j,lm-1,ks)*cf+(vvup*w2+1.)
           rcms_new(i,j,lm,ks)=1./cms
           crs_new(i,j,lm,ks)=0.
!
           rsts(i,j,lm,ks)=-rsts(i,j,lm-1,ks)*cf+s1(i,j,lm,ks) &
                           -(s1(i,j,lm,ks)-s1(i,j,lm-1,ks))*vvup*w1
!
           tcs(i,j,lm,ks)=rsts(i,j,lm,ks)*rcms_new(i,j,lm,ks)-s1(i,j,lm,ks)
           enddo
         enddo
       enddo
      do ks=kss,num_aero                                          !!! only aerosol
       do l=lm-1,1,-1
!        do l=lm-1,3,-1
          do j=jstart,jstop
            do i=its_b1,ite_b1
              tcs(i,j,l,ks)=(-crs_new(i,j,l,ks)*(s1(i,j,l+1,ks)+tcs(i,j,l+1,ks)) &
                             +rsts(i,j,l,ks)) &
                           *rcms_new(i,j,l,ks)-s1(i,j,l,ks)
            enddo
          enddo
        enddo
      enddo

     endif   !! aerosol vertical advection and/or sedimentation
!
!-----------------
#ifdef ENABLE_SMP
!-----------------
!.......................................................................
!$omp end parallel
!.......................................................................
!-----------------
#endif
!-----------------
!-----------------------------------------------------------------------

      if(adv_chem)then ! horizontal advection

!-----------------------------------------------------------------------
!.......................................................................
!$omp parallel do &
!$omp private(fahp,i,ibeg,iend,j,jbeg,jend,ks,l,ss1,ssne,ssnw,ssx,ssy)
!.......................................................................
!
      do ks=kss,kse ! loop by species
!
!-----------------------------------------------------------------------
       do l=1,lm
          do j=jts_h1,jte_h1
            do i=its_h1,ite_h1
              ss1(i,j)=s1(i,j,l,ks)*cfc+sp(i,j,l,ks)*bfc
              sp(i,j,l,ks)=s1(i,j,l,ks)
            enddo
          enddo
!---temperature fluxes, on h points-------------------------------------
          do j=jts_b1,jte_h1
            do i=its_b1,ite_h1
              ssx(i,j)=(ss1(i,j)-ss1(i-1,j))*pfx(i,j,l)
              ssy(i,j)=(ss1(i,j)-ss1(i,j-1))*pfy(i,j,l)
!
              ssne(i,j)=(ss1(i,j)-ss1(i-1,j-1))*pfne(i,j,l)
              ssnw(i,j)=(ss1(i-1,j)-ss1(i,j-1))*pfnw(i,j,l)
            enddo
          enddo
!---advection of species------------------------------------------------
          if(adv_standard)then
            ibeg=max(its,ids+1+lnsad)
            iend=min(ite,ide-1-lnsad)
            jbeg=max(jts,jds+1+lnsad)
            jend=min(jte,jde-1-lnsad)
!
            do j=jbeg,jend
              fahp=fah(j)*idtadt
              do i=ibeg,iend
                tcs(i,j,l,ks)=(((ssx (i  ,j  )+ssx (i+1,j  ) &
                                +ssy (i  ,j  )+ssy (i  ,j+1)) &
                               +(ssne(i+1,j+1)+ssne(i  ,j  ) &
                                +ssnw(i  ,j+1)+ssnw(i+1,j  ))*0.25) &
                               *fahp) &
                             /(dsg2(l)*pdop(i,j)+pdsg1(l)) &
                             +tcs(i,j,l,ks)
              enddo
            enddo
          endif
        enddo
!-----------------------------------------------------------------------
!
      enddo ! end of the loop by the species
!.......................................................................
!$omp end parallel do
!.......................................................................
!
!-----------------------------------------------------------------------
!---regional branch-----------------------------------------------------
!-----------------------------------------------------------------------
      if(.not.global.and.adv_upstream) then
!-----------------------------------------------------------------------
        enhp=-dt*rdyh*0.25*idtadt
!-----------------------------------------------------------------------
        do l=1,lm
!-----------------------------------------------------------------------
!
!***  Upstream advection along southern rows
!
          do j=jts_b1,min(jte,jds+lnsad)
            emhp=-dt*rdxh(j)*0.25*idtadt
            do i=its_b1,ite_b1
              pp=(up(i-1,j-1,l)+up(i  ,j-1,l) &
                 +up(i-1,j  ,l)+up(i  ,j  ,l))*emhp
              qq=(vp(i-1,j-1,l)+vp(i  ,j-1,l) &
                 +vp(i-1,j  ,l)+vp(i  ,j  ,l))*enhp
!
              if(pp.le.0.) then
                iap=-1
                pp=-pp
              else
                iap=1
              endif
!
              if(qq.le.0.) then
                jap=-1
                qq=-qq
              else
                jap=1
              endif
!
              do ks=kss,kse
                tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp &
                             +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq &
                             +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) &
                              -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) &
                             *pp*qq &
                             +tcs(i,j,l,ks)
              enddo
            enddo
          enddo
!
!***  Upstream advection along northern rows
!
          do j=max(jts,jde-lnsad),jte_b1
            emhp=-dt*rdxh(j)*0.25*idtadt
            do i=its_b1,ite_b1
              pp=(up(i-1,j-1,l)+up(i  ,j-1,l) &
                 +up(i-1,j  ,l)+up(i  ,j  ,l))*emhp
              qq=(vp(i-1,j-1,l)+vp(i  ,j-1,l) &
                 +vp(i-1,j  ,l)+vp(i  ,j  ,l))*enhp
!
              if(pp.le.0.) then
                iap=-1
                pp=-pp
              else
                iap=1
              endif
!
              if(qq.le.0.) then
                jap=-1
                qq=-qq
              else
                jap=1
              endif
!
              do ks=kss,kse
                tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp &
                             +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq &
                             +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) &
                              -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) &
                             *pp*qq &
                             +tcs(i,j,l,ks)
              enddo
            enddo
          enddo
!
!***  Upstream advection along western rows
!
          do j=max(jts,jds+1+lnsad),min(jte,jde-1-lnsad)
            emhp=-dt*rdxh(j)*0.25*idtadt
            do i=its_b1,min(ite,ids+lnsad)
              pp=(up(i-1,j-1,l)+up(i  ,j-1,l) &
                 +up(i-1,j  ,l)+up(i  ,j  ,l))*emhp
              qq=(vp(i-1,j-1,l)+vp(i  ,j-1,l) &
                 +vp(i-1,j  ,l)+vp(i  ,j  ,l))*enhp
!
              if(pp.le.0.) then
                iap=-1
                pp=-pp
              else
                iap=1
              endif
!
              if(qq.le.0.) then
                jap=-1
                qq=-qq
              else
                jap=1
              endif
!
              do ks=kss,kse
                tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp &
                             +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq &
                             +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) &
                              -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) &
                             *pp*qq &
                             +tcs(i,j,l,ks)
              enddo
            enddo
          enddo
!
!***  Upstream advection along eastern rows
!
          do j=max(jts,jds+1+lnsad),min(jte,jde-1-lnsad)
            emhp=-dt*rdxh(j)*0.25*idtadt
            do i=max(its,ide-lnsad),ite_b1
              pp=(up(i-1,j-1,l)+up(i  ,j-1,l) &
                 +up(i-1,j  ,l)+up(i  ,j  ,l))*emhp
              qq=(vp(i-1,j-1,l)+vp(i  ,j-1,l) &
                 +vp(i-1,j  ,l)+vp(i  ,j  ,l))*enhp
!
              if(pp.le.0.) then
                iap=-1
                pp=-pp
              else
                iap=1
              endif
!
              if(qq.le.0.) then
                jap=-1
                qq=-qq
              else
                jap=1
              endif
!
              do ks=kss,kse
                tcs(i,j,l,ks)=(s1(i+iap,j,l,ks)-s1(i,j,l,ks))*pp &
                             +(s1(i,j+jap,l,ks)-s1(i,j,l,ks))*qq &
                             +(s1(i,j,l,ks)-s1(i+iap,j,l,ks) &
                              -s1(i,j+jap,l,ks)+s1(i+iap,j+jap,l,ks)) &
                             *pp*qq &
                             +tcs(i,j,l,ks)
              enddo
            enddo
          enddo
!-----------------------------------------------------------------------
        enddo
!-----------------------------------------------------------------------
      endif ! regional lateral boundaries
!-----------------------------------------------------------------------
!
      endif ! endif adv_chem (horizontal advection)

                        endsubroutine adv2_chem
!
!-----------------------------------------------------------------------
!MONARCH
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
                        subroutine mono_chem &
(idtadt,kss,kse,lm &
,dsg2,pdsg1 &
,dare &
,pd &
,s &
,inpes,jnpes &
,use_allreduce &
!MONARCH
,mass_fixer &
!---temporary arguments-------------------------------------------------
,s1,tcs)
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

implicit none

!-----------------------------------------------------------------------
real(kind=kfpt),parameter:: &
 epsq=1.e-20 &               ! floor value for specific humidity
,epsq2=0.02                  ! floor value for 2tke

integer(kind=kint),intent(in):: &
 idtadt &                    !
,inpes &                     ! number of tasks in x direction
,jnpes &                     ! number of tasks in y direction
,kse &                       ! terminal species index
,kss &                       ! initial species index
,lm                          ! total # of levels

real(kind=kfpt),dimension(1:lm),intent(in):: &
 dsg2 &                      ! delta sigmas
,pdsg1                       ! delta pressures

real(kind=kfpt),dimension(jds:jde),intent(in):: &
 dare                        ! grid box area

real(kind=kfpt),dimension(ims:ime,jms:jme),intent(in):: &
 pd                          ! sigma range pressure difference

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:kse),intent(inout):: &
 s                           ! s at previous time level

logical(kind=klog) :: &
 use_allreduce

integer(kind=kint),intent(in):: &
mass_fixer
!MONARCH

!---temporary arguments-------------------------------------------------
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:kse),intent(inout):: &
 s1 &                        ! intermediate value of s
,tcs                         ! timechange of s
!--local variables------------------------------------------------------
integer(kind=kint):: &
 i &                         !
,ierr &                      !
,irecv &                     !
,j &                         !
,ks &                        !
,l &                         !
,lngth &                     !
,loc_its_b1 &                !
,loc_ite_b1 &                !
,loc_jts_b1 &                !
,loc_jte_b1 &                !
,loc_len &                   !
,loc_lngth &                 !
,n &                         !
,nn &                        !
,pe                          !

integer,dimension(mpi_status_size) :: jstat

real(kind=kfpt):: &
 s1p &                       !
,smax &                      ! local maximum
,smin &                      ! local minimum
,smaxh &                     ! horizontal local maximum
,sminh &                     ! horizontal local minimum
,smaxv &                     ! vertical local maximum
,sminv &                     ! vertical local minimum
,sn &                        !
,steep                       !

real(kind=kdbl):: &
 dsp &                       !
,rfacs &                     !
,sfacs &                     !
,sumns &                     !
,sumps &                     !
!MONARCH
,sprev &
,snext &
,wg1s &
,wg2s

real(kind=kdbl),dimension(kss:kse):: &
 dm &
,lambda


real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:kse):: &
 wg1 &
,wg2 

real(kind=kdbl),dimension(ide*jde*(kse-kss+1)):: &
 s1_glob                     !

real(kind=kfpt),dimension((ite_b1-its_b1+1)*(jte_b1-jts_b1+1)*(kse-kss+1)):: &
 s1_loc                      !

real(kind=kfpt),dimension(:), allocatable :: &
 s1_pe_loc                   !

real(kind=kdbl),dimension(2*kss-1:2*kse):: &
 gsums &                     ! sum of neg/pos changes all global fields
,xsums                       ! sum of neg/pos changes all global fields
!MONARCH
real(kind=kdbl),dimension(kss:kse):: &
 gsumss &
,xsumss

real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1,kss:kse):: &
 s1l_sum

real(kind=kfpt),dimension(its_b1:ite_b1,jts_b1:jte_b1,1:lm):: &
 dvol &                      ! grid box volume
,rdvol                       ! 1./grid box volume
!-----------------------------------------------------------------------
integer(kind=kint) :: &
 istat

logical(kind=klog) :: &
 opened

logical(kind=klog),save :: &
 sum_file_is_open=.false.

character(10) :: &
 fstatus
!-----------------------------------------------------------------------
real(kind=kdbl),save :: sumdo3=0.
!-----------------------------------------------------------------------
!MONARCH
real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,kss:kse) :: &
 s1_int                         ! intermediate value of s (internal)
!MONARCH
!***********************************************************************
!-----------------------------------------------------------------------
!
      steep=1.-0.040*idtadt
!.......................................................................
!$omp parallel 
!$omp do private(i,j,l)
!.......................................................................
      do l=1,lm
        do j=jts_b1,jte_b1
          do i=its_b1,ite_b1
            dvol (i,j,l)=(dsg2(l)*pd(i,j)+pdsg1(l))*dare(j)
            rdvol(i,j,l)=1./dvol(i,j,l)
          enddo
        enddo
      enddo
!.......................................................................
!$omp end do
!$omp end parallel
!.......................................................................
!
!-----------------------------------------------------------------------
!---monotonization------------------------------------------------------
!-----------------------------------------------------------------------
!
      if(use_allreduce)then
!
!-----------------------------------------------------------------------
!.......................................................................
!$omp parallel 
!$omp do private (dsp,i,j,ks,l,s1p,smax,smaxh,smaxv,smin,sminh,sminv,sn)
!.......................................................................
!-----------------------------------------------------------------------
      do ks=kss,kse ! loop by species
          gsums(2*ks-1)=0.
          gsums(2*ks  )=0.
          xsums(2*ks-1)=0.
          xsums(2*ks  )=0.
!
        do j=jts_b1,jte_b1
          do i=its_b1,ite_b1
            s1l_sum(i,j,ks)=0.
          enddo
        enddo
!-----------------------------------------------------------------------
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
!MONARCH
              s1_int(i,j,l,ks)=s1(i,j,l,ks)
!MONARCH
              s1p=(s1(i,j,l,ks)+tcs(i,j,l,ks))**2
              tcs(i,j,l,ks)=s1p-s(i,j,l,ks)
!
              sminh=min(s(i-1,j-1,l,ks) &
                       ,s(i  ,j-1,l,ks) &
                       ,s(i+1,j-1,l,ks) &
                       ,s(i-1,j  ,l,ks) &
                       ,s(i  ,j  ,l,ks) &
                       ,s(i+1,j  ,l,ks) &
                       ,s(i-1,j+1,l,ks) &
                       ,s(i  ,j+1,l,ks) &
                       ,s(i+1,j+1,l,ks))
              smaxh=max(s(i-1,j-1,l,ks) &
                       ,s(i  ,j-1,l,ks) &
                       ,s(i+1,j-1,l,ks) &
                       ,s(i-1,j  ,l,ks) &
                       ,s(i  ,j  ,l,ks) &
                       ,s(i+1,j  ,l,ks) &
                       ,s(i-1,j+1,l,ks) &
                       ,s(i  ,j+1,l,ks) &
                       ,s(i+1,j+1,l,ks))
!
              if(l.gt.1.and.l.lt.lm) then
                sminv=min(s(i,j,l-1,ks),s(i,j,l  ,ks),s(i,j,l+1,ks))
                smaxv=max(s(i,j,l-1,ks),s(i,j,l  ,ks),s(i,j,l+1,ks))
              elseif(l.eq.1) then
                sminv=min(s(i,j,l  ,ks),s(i,j,l+1,ks))
                smaxv=max(s(i,j,l  ,ks),s(i,j,l+1,ks))
              elseif(l.eq.lm) then
                sminv=min(s(i,j,l-1,ks),s(i,j,l  ,ks))
                smaxv=max(s(i,j,l-1,ks),s(i,j,l  ,ks))
              endif
!
              smin=min(sminh,sminv)
              smax=max(smaxh,smaxv)
!
              sn=s1p
              if(sn.gt.steep*smax) sn=smax
              if(sn.lt.     smin) sn=smin
!
              dsp=(sn-s1p)*dvol(i,j,l)
!
              if(dsp.gt.0.) then
                xsums(2*ks-1)=xsums(2*ks-1)+dsp
              else
                xsums(2*ks  )=xsums(2*ks  )+dsp
              endif
!
            enddo
          enddo
        enddo
      enddo ! end of the loop by species
!.......................................................................
!$omp end do
!$omp end parallel
!.......................................................................
!-----------------------------------------------------------------------
!
      else ! use send/recv
!
!-----------------------------------------------------------------------
!.......................................................................
!$omp parallel 
!$omp do private (dsp,i,j,ks,l,s1p,smax,smaxh,smaxv,smin,sminh,sminv,sn)
!.......................................................................
!-----------------------------------------------------------------------
      do ks=kss,kse ! loop by species
          gsums(2*ks-1)=0.
          gsums(2*ks  )=0.
!
        do j=jts_b1,jte_b1
          do i=its_b1,ite_b1
            s1l_sum(i,j,ks)=0.
          enddo
        enddo
!-----------------------------------------------------------------------
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
              s1p=(s1(i,j,l,ks)+tcs(i,j,l,ks))**2
              tcs(i,j,l,ks)=s1p-s(i,j,l,ks)
!
              sminh=min(s(i-1,j-1,l,ks) &
                       ,s(i  ,j-1,l,ks) &
                       ,s(i+1,j-1,l,ks) &
                       ,s(i-1,j  ,l,ks) &
                       ,s(i  ,j  ,l,ks) &
                       ,s(i+1,j  ,l,ks) &
                       ,s(i-1,j+1,l,ks) &
                       ,s(i  ,j+1,l,ks) &
                       ,s(i+1,j+1,l,ks))
              smaxh=max(s(i-1,j-1,l,ks) &
                       ,s(i  ,j-1,l,ks) &
                       ,s(i+1,j-1,l,ks) &
                       ,s(i-1,j  ,l,ks) &
                       ,s(i  ,j  ,l,ks) &
                       ,s(i+1,j  ,l,ks) &
                       ,s(i-1,j+1,l,ks) &
                       ,s(i  ,j+1,l,ks) &
                       ,s(i+1,j+1,l,ks))
!
              if(l.gt.1.and.l.lt.lm) then
                sminv=min(s(i,j,l-1,ks),s(i,j,l  ,ks),s(i,j,l+1,ks))
                smaxv=max(s(i,j,l-1,ks),s(i,j,l  ,ks),s(i,j,l+1,ks))
              elseif(l.eq.1) then
                sminv=min(s(i,j,l  ,ks),s(i,j,l+1,ks))
                smaxv=max(s(i,j,l  ,ks),s(i,j,l+1,ks))
              elseif(l.eq.lm) then
                sminv=min(s(i,j,l-1,ks),s(i,j,l  ,ks))
                smaxv=max(s(i,j,l-1,ks),s(i,j,l  ,ks))
              endif
!
              smin=min(sminh,sminv)
              smax=max(smaxh,smaxv)
!
              sn=s1p
              if(sn.gt.steep*smax) sn=smax
              if(sn.lt.     smin) sn=smin
!
              dsp=(sn-s1p)*dvol(i,j,l)
!
              s1(i,j,l,ks)=dsp
              s1l_sum(i,j,ks) = s1l_sum(i,j,ks) + dsp
!
            enddo
          enddo
        enddo
      enddo ! end of the loop by species
!.......................................................................
!$omp end do
!$omp end parallel
!.......................................................................
!-----------------------------------------------------------------------
!
      endif
!
!-----------------------------------------------------------------------
!***  Global reductions
!-----------------------------------------------------------------------
!
      global_reduce: if(use_allreduce)then
!
!-----------------------------------------------------------------------
!***  Skip computing the global reduction if they are to be read in
!***  from another run to check bit reproducibility.
!-----------------------------------------------------------------------
        lngth=2*kse-2*kss+2
        call mpi_allreduce(xsums,gsums,lngth &
                          ,mpi_double_precision &
                          ,mpi_sum,mpi_comm_comp,irecv)
!-----------------------------------------------------------------------
!
      else  global_reduce
!
!-----------------------------------------------------------------------
        if (mype==0) then

          do ks=kss,kse
            do j=jts_b1,jte_b1
              do i=its_b1,ite_b1
                n=i+(j-1)*ide+(ks-1)*ide*jde
                s1_glob(n) = s1l_sum(i,j,ks)
              enddo
            enddo
          enddo

          do pe=1,inpes*jnpes-1
            loc_its_b1 = max(local_istart(pe),ids+1)
            loc_ite_b1 = min(local_iend  (pe),ide-1)
            loc_jts_b1 = max(local_jstart(pe),jds+1)
            loc_jte_b1 = min(local_jend  (pe),jde-1)
            loc_len    = (loc_ite_b1-loc_its_b1+1)*    &
                         (loc_jte_b1-loc_jts_b1+1)*(kse-kss+1)
            allocate(s1_pe_loc(1:loc_len))
            call mpi_recv(s1_pe_loc(1:loc_len),loc_len &
                         ,mpi_real,pe,pe,mpi_comm_comp,jstat,ierr)
            nn=0
            do ks=kss,kse
              do j=loc_jts_b1,loc_jte_b1
                do i=loc_its_b1,loc_ite_b1
                  nn=nn+1
                  n=i+(j-1)*ide+(ks-1)*ide*jde
                  s1_glob(n) = s1_pe_loc(nn)
                enddo
              enddo
            enddo
            deallocate(s1_pe_loc)
          end do

          do ks=kss,kse
            do j=jds+1,jde-1
              do i=ids+1,ide-1
                n=i+(j-1)*ide+(ks-1)*ide*jde
                if(s1_glob(n).gt.0.0d0) then
                  gsums(2*ks-1) = gsums(2*ks-1) + s1_glob(n)
                else
                  gsums(2*ks  ) = gsums(2*ks  ) + s1_glob(n)
                endif
              enddo
            enddo
          enddo

        else
          loc_lngth=(ite_b1-its_b1+1)*(jte_b1-jts_b1+1)*(kse-kss+1)

          n=0
          do ks=kss,kse
            do j=jts_b1,jte_b1
              do i=its_b1,ite_b1
                n=n+1
                s1_loc(n) = s1l_sum(i,j,ks)
              enddo
            enddo
          enddo
          call mpi_send(s1_loc(1:loc_lngth),loc_lngth &
                       ,mpi_real, 0, mype, mpi_comm_comp, ierr)

        endif

        call mpi_bcast(gsums,(kse-kss+1)*2 &
                      ,mpi_double_precision,0,mpi_comm_comp,ierr)

!----------------------------------------------------------------------
!
      endif  global_reduce
!
!----------------------------------------------------------------------
!.......................................................................
!$omp parallel do private (dsp,i,j,ks,l,rfacs,sfacs,sumns,sumps)
!.......................................................................
      do ks=kss,kse
        sumps=gsums(2*ks-1)
        sumns=gsums(2*ks  )
!
        if(sumps*(-sumns).gt.1.) then
          sfacs=-sumns/sumps
          rfacs=1./sfacs
        else
          sfacs=0.
          rfacs=0.
        endif
!
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
              dsp=s1(i,j,l,ks)*rdvol(i,j,l)
              if(sfacs.lt.1.) then
                if(dsp.gt.0.) dsp=dsp*sfacs
              else
                if(dsp.lt.0.) dsp=dsp*rfacs
              endif
              tcs(i,j,l,ks)=tcs(i,j,l,ks)+dsp
            enddo
          enddo
        enddo
!-----------------------------------------------------------------------
!
      enddo ! end of the loop by species
!.......................................................................
!
!MONARCH--------mass_fixer based on McGregor(2005) 
!
!
      if(mass_fixer.eq.1)then
!
!-----------------------------------------------------------------------
      do ks=kss,kse ! loop by species
          gsums(2*ks-1)=0.
          gsums(2*ks  )=0.
          xsums(2*ks-1)=0.
          xsums(2*ks  )=0.
!
        do j=jts_b1,jte_b1
          do i=its_b1,ite_b1
            s1l_sum(i,j,ks)=0.
          enddo
        enddo
!-----------------------------------------------------------------------
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
!
              dsp=tcs(i,j,l,ks)*dvol(i,j,l)
              s1_int(i,j,l,ks)=dsp
!
              if(dsp.gt.0.) then
                xsums(2*ks-1)=xsums(2*ks-1)+dsp
              else
                xsums(2*ks  )=xsums(2*ks  )+dsp
              endif
!
            enddo
          enddo
        enddo
      enddo ! end of the loop by species
!-----------------------------------------------------------------------
!
          lngth=2*kse-2*kss+2
          call mpi_allreduce(xsums,gsums,lngth &
                            ,mpi_double_precision &
                            ,mpi_sum,mpi_comm_comp,irecv)
!
!-----------------------------------------------------------------------
!
      do ks=kss,kse
        sumps=gsums(2*ks-1)
        sumns=gsums(2*ks  )
!
!        if(sumps*(-sumns).gt.1.) then
        if(sumps.gt.0.)then
          sfacs=-sumns/sumps
!          rfacs=1./sfacs
!        else
!          sfacs=0.
!          rfacs=0.
!        endif
!
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
              dsp=s1_int(i,j,l,ks)*rdvol(i,j,l)
              if(sfacs.lt.1.) then

                if(dsp.gt.0.)then 
                  dsp=dsp*min(sfacs,sqrt(sfacs))
                endif
!  
              else
                if(dsp.lt.0.)then 
                  dsp=dsp/min(sfacs,sqrt(sfacs))
                else
                  dsp=dsp*min(sfacs,sqrt(sfacs))
                endif
!
              endif
!              tcs(i,j,l,ks)=tcs(i,j,l,ks)+dsp
               tcs(i,j,l,ks)=dsp
            enddo
          enddo
        enddo
!-----------------------------------------------------------------------
!
       endif
      
      enddo ! end of the loop by species
!
      endif !mass_fixer
!
!Another mass fixer

      if(mass_fixer.eq.2.or.mass_fixer.eq.3.or.mass_fixer.eq.4)then
!
!-----------------------------------------------------------------------
      do ks=kss,kse ! loop by species
          gsums(2*ks-1)=0.
          gsums(2*ks  )=0.
          xsums(2*ks-1)=0.
          xsums(2*ks  )=0.
!-----------------------------------------------------------------------
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
!
              sprev=s(i,j,l,ks)*dvol(i,j,l)                    !previous
              snext=(s(i,j,l,ks)+tcs(i,j,l,ks))*dvol(i,j,l)    !non conservative update
!
                xsums(2*ks-1)=xsums(2*ks-1)+sprev
                xsums(2*ks  )=xsums(2*ks  )+snext
!
            enddo
          enddo
        enddo
      enddo ! end of the loop by species
!-----------------------------------------------------------------------
!
          lngth=2*kse-2*kss+2
          call mpi_allreduce(xsums,gsums,lngth &
                            ,mpi_double_precision &
                            ,mpi_sum,mpi_comm_comp,irecv)
!
!-----------------------------------------------------------------------
!
      do ks=kss,kse
        sumps=gsums(2*ks-1)
        sumns=gsums(2*ks  )

        dm(ks)=sumns-sumps

        gsumss(ks)=0.
        xsumss(ks)=0.
        lambda(ks)=0.

        if(mass_fixer.eq.2)then

!Weights for Bermejo and Conde scheme
!proportional to the tendency
!where there is more change, there is more correction

        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1

            if(dm(ks).gt.0.) then
             wg1(i,j,l,ks)=max(0.,tcs(i,j,l,ks))                    
            elseif(dm(ks).lt.0.) then
             wg1(i,j,l,ks)=max(0.,-tcs(i,j,l,ks))             
            else
             wg1(i,j,l,ks)=0.
            endif

             wg1s=wg1(i,j,l,ks)*dvol(i,j,l)
             xsumss(ks)=xsumss(ks)+wg1s

            enddo
           enddo
         enddo
!
       endif !mass_fixer.eq.2
!
       if(mass_fixer.eq.3)then

!variation of Bermejo and Conde scheme proportional also to the mass in the gridcell
!where there is more mass there is also more correction

        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1

            if(dm(ks).gt.0.) then
             wg2(i,j,l,ks)=max(0.,(s(i,j,l,ks)+tcs(i,j,l,ks))*dvol(i,j,l)*tcs(i,j,l,ks))
            elseif(dm(ks).lt.0.) then
             wg2(i,j,l,ks)=max(0.,-(s(i,j,l,ks)+tcs(i,j,l,ks))*dvol(i,j,l)*tcs(i,j,l,ks))
            else
             wg2(i,j,l,ks)=0.
            endif
!
            wg2s=wg2(i,j,l,ks)*dvol(i,j,l)
            xsumss(ks)=xsumss(ks)+wg2s
!
            enddo
          enddo
        enddo

        endif !mass_fixer.eq.3
!
       if(mass_fixer.eq.4)then

!variation of Bermejo and Conde scheme proportional also to the mass^2 in the gridcell
!where there is more mass there is also more correction (QUADRATIC)

        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1

            if(dm(ks).gt.0.) then
             wg2(i,j,l,ks)=max(0.,sign((s(i,j,l,ks)+tcs(i,j,l,ks))**2*dvol(i,j,l)*tcs(i,j,l,ks)**2,tcs(i,j,l,ks)))
            elseif(dm(ks).lt.0.) then
             wg2(i,j,l,ks)=max(0.,-sign((s(i,j,l,ks)+tcs(i,j,l,ks))**2*dvol(i,j,l)*tcs(i,j,l,ks)**2,tcs(i,j,l,ks)))
            else
             wg2(i,j,l,ks)=0.
            endif
!
            wg2s=wg2(i,j,l,ks)*dvol(i,j,l)
            xsumss(ks)=xsumss(ks)+wg2s
!
            enddo
          enddo
        enddo

        endif !mass_fixer.eq.4
!



      enddo ! end of the loop by species

!-----------------------------------------------------------------------
!
          lngth=kse-kss+1
          call mpi_allreduce(xsumss,gsumss,lngth &
                            ,mpi_double_precision &
                            ,mpi_sum,mpi_comm_comp,irecv)
!
!-----------------------------------------------------------------------
!
      do ks=kss,kse
        sumps=gsumss(ks)    !sum of wg1s or wg2s
!
        if(sumps.ne.0.) lambda(ks)=dm(ks)/sumps
!
        if(mass_fixer.eq.2)then
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
!           
            tcs(i,j,l,ks)=tcs(i,j,l,ks)-lambda(ks)*wg1(i,j,l,ks)
!
            enddo
          enddo
        enddo
        endif
!
        if(mass_fixer.eq.3.or.mass_fixer.eq.4)then
        do l=1,lm
          do j=jts_b1,jte_b1
            do i=its_b1,ite_b1
!           
            tcs(i,j,l,ks)=tcs(i,j,l,ks)-lambda(ks)*wg2(i,j,l,ks)
!
            enddo
          enddo
        enddo
        endif
!
      enddo ! end of the loop by species
!
      endif  !mass_fixers 2 and 3

!!MONARCH
!!$omp end parallel do 
!.......................................................................
!
!-----------------------------------------------------------------------
!MONARCH      do l=1,lm
!MONARCH        do j=jts_b1,jte_b1
!MONARCH          do i=its_b1,ite_b1
!MONARCH            tcs(i,j,l,indx_q2)=(dsg2(l)*pd(i,j)+pdsg1(l))*tcs(i,j,l,indx_q2)
!MONARCH          enddo
!MONARCH        enddo
!MONARCH      enddo
!MONARCH      do l=1,lm-1
!MONARCH        do j=jts_b1,jte_b1
!MONARCH          do i=its_b1,ite_b1
!MONARCH            tcs(i,j,l,indx_q2)=(tcs(i,j,l,indx_q2)+tcs(i,j,l+1,indx_q2)) &
!MONARCH                        /((dsg2(l  )*pd(i,j)+pdsg1(l  )) &
!MONARCH                         +(dsg2(l+1)*pd(i,j)+pdsg1(l+1)))
!MONARCH          enddo
!MONARCH        enddo
!MONARCH      enddo
!MONARCH      do j=jts_b1,jte_b1
!MONARCH        do i=its_b1,ite_b1
!MONARCH          tcs(i,j,lm,indx_q2)=0.
!MONARCH        enddo
!MONARCH      enddo
!MONARCH
!-----------------------------------------------------------------------
!
                        endsubroutine mono_chem
!
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
                        subroutine read_bc_chem &
(lm,lnsh,ntsd,dt &
,runbc,idatbc,ihrstbc,tboco &
!,pdbs,pdbn,pdbw,pdbe &
!,tbs,tbn,tbw,tbe &
,num_bc_chem &
,qbs,qbn,qbw,qbe )
!,wbs,wbn,wbw,wbe &
!,ubs,ubn,ubw,ube &
!,vbs,vbn,vbw,vbe)
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
!
implicit none
!
!-----------------------------------------------------------------------
!
!include 'kind.inc'
!
!-----------------------------------------------------------------------
integer(kind=kint),intent(in):: &
 lm  &                       ! total # of levels
,lnsh &                      ! # of boundary h lines for bc in reg. setup
!,lnsv &                      ! # of boundary v lines for bc in reg. setup
!MONARCH
,num_bc_chem &               ! # of gases in BC
!MONARCH
,ntsd                        ! current timestep

integer(kind=kint),intent(out):: &
 ihrstbc                     ! boundary conditions starting time

integer(kind=kint),dimension(1:3),intent(out):: &
 idatbc                      ! date of boundary data, day, month, year

real(kind=kfpt),intent(in):: &
 dt                          ! dynamics time step

real(kind=kfpt),intent(out):: &
 tboco                       ! boundary conditions interval, hours

!real(kind=kfpt),dimension(ims:ime,1:lnsh,1:2),intent(out):: &
! pdbn &                      ! pressure difference at northern boundary
!,pdbs                        ! pressure difference at southern boundary

!real(kind=kfpt),dimension(1:lnsh,jms:jme,1:2),intent(out):: &
! pdbe &                      ! pressure difference at eastern boundary
!,pdbw                        ! pressure difference at western boundary

real(kind=kfpt),dimension(ims:ime,1:lnsh,1:lm,1:2,1:num_bc_chem),intent(out):: &
! tbn &                       ! temperature at northern boundary
!,tbs &                       ! temperature at southern boundary
 qbn &                       ! specific humidity at northern boundary
,qbs                         ! specific humidity at southern boundary
!,wbn &                       ! condensate at northern boundary
!,wbs                         ! condensate at southern boundary

real(kind=kfpt),dimension(1:lnsh,jms:jme,1:lm,1:2,1:num_bc_chem),intent(out):: &
! tbe &                       ! temperature at eastern boundary
!,tbw &                       ! temperature at western boundary
 qbe &                       ! specific humidity at eastern boundary
,qbw                         ! specific humidity at western boundary
!,wbe &                       ! condensate at eastern boundary
!,wbw                         ! condensate at western boundary

!real(kind=kfpt),dimension(ims:ime,1:lnsv,1:lm,1:2),intent(out):: &
! ubn &                       ! u wind component at northern boundary
!,ubs &                       ! u wind component at southern boundary
!,vbn &                       ! v wind component at northern boundary
!,vbs                         ! v wind component at southern boundary

!real(kind=kfpt),dimension(1:lnsv,jms:jme,1:lm,1:2),intent(out):: &
! ube &                       ! u wind component at eastern boundary
!,ubw &                       ! u wind component at western boundary
!,vbe &                       ! v wind component at eastern boundary
!,vbw                         ! v wind component at western boundary

logical(kind=klog) :: runbc
!-----------------------------------------------------------------------
!---local variables-----------------------------------------------------
!-----------------------------------------------------------------------
integer(kind=kint):: &
 i &                         ! index in x direction
,i_hi &                      ! max i loop limit (cannot be > ide)
,i_lo &                      ! min i loop limit (cannot be < ids)
,ihr &                       ! current hour
,ihrbc &                     ! current hour for bc's
,istat &                     ! return status
,iunit &                     ! file unit number
,j_hi &                      ! max j loop limit (cannot be > jde)
,j_lo &                      ! min j loop limit (cannot be < jds)
,l &
,n1 &                        ! dimension 1 of working arrays
,n2 &                        ! dimension 2 of working arrays
,n3 &                        ! dimension 3 of working arrays
,n4 &                        ! dimension 4 of working arrays
!MONARCH
,n5                          ! dimension 5 of working arrays
!MONARCH
!real(kind=kfpt),allocatable,dimension(:,:,:) :: pdbe_g,pdbn_g,pdbs_g,pdbw_g

real(kind=kfpt),allocatable,dimension(:,:,:,:) :: qbe_g,qbn_g,qbs_g,qbw_g
!                                                 ,tbe_g,tbn_g,tbs_g,tbw_g &
!                                                 ,ube_g,ubn_g,ubs_g,ubw_g &
!                                                 ,vbe_g,vbn_g,vbs_g,vbw_g & 
!                                                 ,wbe_g,wbn_g,wbs_g,wbw_g 
character(64) :: infile
logical(kind=klog) :: opened
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
!
!-----------------------------------------------------------------------
!***  Allocate temporary working arrays.
!-----------------------------------------------------------------------
!
!      allocate(pdbe_g(1:lnsh,jds:jde,1:2),stat=i)
!      allocate(pdbw_g(1:lnsh,jds:jde,1:2),stat=i)
!      allocate(pdbn_g(ids:ide,1:lnsh,1:2),stat=i)
!      allocate(pdbs_g(ids:ide,1:lnsh,1:2),stat=i)
!
!      allocate(tbe_g(1:lnsh,jds:jde,1:lm,1:2),stat=istat)
!      allocate(tbw_g(1:lnsh,jds:jde,1:lm,1:2),stat=istat)
!      allocate(tbn_g(ids:ide,1:lnsh,1:lm,1:2),stat=istat)
!      allocate(tbs_g(ids:ide,1:lnsh,1:lm,1:2),stat=istat)
      allocate(qbe_g(1:lnsh,jds:jde,1:lm,1:2),stat=istat)
      allocate(qbw_g(1:lnsh,jds:jde,1:lm,1:2),stat=istat)
      allocate(qbn_g(ids:ide,1:lnsh,1:lm,1:2),stat=istat)
      allocate(qbs_g(ids:ide,1:lnsh,1:lm,1:2),stat=istat)
!      allocate(wbe_g(1:lnsh,jds:jde,1:lm,1:2),stat=istat)
!      allocate(wbw_g(1:lnsh,jds:jde,1:lm,1:2),stat=istat)
!      allocate(wbn_g(ids:ide,1:lnsh,1:lm,1:2),stat=istat)
!      allocate(wbs_g(ids:ide,1:lnsh,1:lm,1:2),stat=istat)
!
!      allocate(ube_g(1:lnsv,jds:jde,1:lm,1:2),stat=istat)
!      allocate(ubw_g(1:lnsv,jds:jde,1:lm,1:2),stat=istat)
!      allocate(ubn_g(ids:ide,1:lnsv,1:lm,1:2),stat=istat)
!      allocate(ubs_g(ids:ide,1:lnsv,1:lm,1:2),stat=istat)
!      allocate(vbe_g(1:lnsv,jds:jde,1:lm,1:2),stat=istat)
!      allocate(vbw_g(1:lnsv,jds:jde,1:lm,1:2),stat=istat)
!      allocate(vbn_g(ids:ide,1:lnsv,1:lm,1:2),stat=istat)
!      allocate(vbs_g(ids:ide,1:lnsv,1:lm,1:2),stat=istat)
!
!-----------------------------------------------------------------------
!***  Because subdomains that lie along the global domain boundary
!***  may have haloes that extend beyond the global limits, create
!***  limits here that keep loops from reaching beyond those
!***  global limits.
!-----------------------------------------------------------------------
!
      i_lo=max(ims,ids)
      i_hi=min(ime,ide)
      j_lo=max(jms,jds)
      j_hi=min(jme,jde)
!
!-----------------------------------------------------------------------
!***  Read in boundary variables and arrays. 
!-----------------------------------------------------------------------
!
      ihr=nint(ntsd*dt/3600.)
      ihrbc=ihr
      write(infile,'(a,i4.4)')'boco_chem.',ihrbc
!
      select_unit: do l=51,59
        inquire(l,opened=opened)
        if(.not.opened)then
          iunit=l
          exit select_unit
        endif
      enddo select_unit
!
      open(unit=iunit,file=infile,status='OLD' &
          ,form='UNFORMATTED',iostat=istat)
!
      read(iunit)runbc,idatbc,ihrstbc,tboco
!
!      read(iunit)pdbs_g,pdbn_g,pdbw_g,pdbe_g
!
!      do n3=1,2
!        do n2=1,lnsh
!!       do n1=ims,ime
!        do n1=i_lo,i_hi
!          pdbn(n1,n2,n3)=pdbn_g(n1,n2,n3)
!          pdbs(n1,n2,n3)=pdbs_g(n1,n2,n3)
!        enddo
!        enddo
!
!!       do n2=jms,jme
!        do n2=j_lo,j_hi
!        do n1=1,lnsh
!          pdbe(n1,n2,n3)=pdbe_g(n1,n2,n3)
!          pdbw(n1,n2,n3)=pdbw_g(n1,n2,n3)
!        enddo
!        enddo
!      enddo
!
!      deallocate(pdbe_g,pdbn_g,pdbs_g,pdbw_g)
!     
!      read(iunit)tbs_g,tbn_g,tbw_g,tbe_g
      do n5=1,num_bc_chem
      read(iunit)qbs_g,qbn_g,qbw_g,qbe_g
!      read(iunit)wbs_g,wbn_g,wbw_g,wbe_g
!       
      do n4=1,2
      do n3=1,lm
        do n2=1,lnsh
!       do n1=ims,ime
        do n1=i_lo,i_hi
!          tbn(n1,n2,n3,n4)=tbn_g(n1,n2,n3,n4)
!          tbs(n1,n2,n3,n4)=tbs_g(n1,n2,n3,n4) 
          qbn(n1,n2,n3,n4,n5)=qbn_g(n1,n2,n3,n4)
          qbs(n1,n2,n3,n4,n5)=qbs_g(n1,n2,n3,n4)
!          wbn(n1,n2,n3,n4)=wbn_g(n1,n2,n3,n4)
!          wbs(n1,n2,n3,n4)=wbs_g(n1,n2,n3,n4)
        enddo
        enddo
!
!       do n2=jms,jme
        do n2=j_lo,j_hi
        do n1=1,lnsh
!          tbe(n1,n2,n3,n4)=tbe_g(n1,n2,n3,n4)
!          tbw(n1,n2,n3,n4)=tbw_g(n1,n2,n3,n4)
          qbe(n1,n2,n3,n4,n5)=qbe_g(n1,n2,n3,n4)
          qbw(n1,n2,n3,n4,n5)=qbw_g(n1,n2,n3,n4)
!          wbe(n1,n2,n3,n4)=wbe_g(n1,n2,n3,n4)
!          wbw(n1,n2,n3,n4)=wbw_g(n1,n2,n3,n4)
        enddo
        enddo
      enddo
      enddo
      enddo
!
      deallocate(qbe_g)
      deallocate(qbn_g)
      deallocate(qbs_g)
      deallocate(qbw_g)
!      deallocate(tbe_g)
!      deallocate(tbn_g)
!      deallocate(tbs_g)
!      deallocate(tbw_g)
!      deallocate(wbe_g)
!      deallocate(wbn_g)
!      deallocate(wbs_g)
!      deallocate(wbw_g)
!
!      read(iunit)ubs_g,ubn_g,ubw_g,ube_g
!      read(iunit)vbs_g,vbn_g,vbw_g,vbe_g
!
!      do n4=1,2
!      do n3=1,lm
!        do n2=1,lnsv
!!       do n1=ims,ime
!        do n1=i_lo,i_hi
!          ubn(n1,n2,n3,n4)=ubn_g(n1,n2,n3,n4)       
!          ubs(n1,n2,n3,n4)=ubs_g(n1,n2,n3,n4)       
!          vbn(n1,n2,n3,n4)=vbn_g(n1,n2,n3,n4)       
!          vbs(n1,n2,n3,n4)=vbs_g(n1,n2,n3,n4)       
!        enddo
!        enddo
!
!!       do n2=jms,jme
!        do n2=j_lo,j_hi
!        do n1=1,lnsv
!          ube(n1,n2,n3,n4)=ube_g(n1,n2,n3,n4)
!          ubw(n1,n2,n3,n4)=ubw_g(n1,n2,n3,n4)
!          vbe(n1,n2,n3,n4)=vbe_g(n1,n2,n3,n4)
!          vbw(n1,n2,n3,n4)=vbw_g(n1,n2,n3,n4)
!        enddo
!        enddo
!      enddo
!      enddo
!     
!      deallocate(ube_g)
!      deallocate(ubn_g)
!      deallocate(ubs_g)
!      deallocate(ubw_g)
!      deallocate(vbe_g)
!      deallocate(vbn_g)
!      deallocate(vbs_g)
!      deallocate(vbw_g)
!
      close(iunit)
!
!-----------------------------------------------------------------------
                        end subroutine read_bc_chem
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
!
                        subroutine bocoh_chem &
(lm,lnsh &
,dt,num_tracers_chem & !,pt &
,num_aero &
!,dsg2,pdsg1 &
!,pd &
!,pdbe,pdbn,pdbs,pdbw &
!,tbe,tbn,tbs,tbw,qbe,qbn,qbs,qbw,wbe,wbn,wbs,wbw &
,qbe,qbn,qbs,qbw &
!,t,q,cw &
,num_bc_chem &
,qchem) ! &
!,pint)
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!-----------------------------------------------------------------------
implicit none
!-----------------------------------------------------------------------

!include 'kind.inc'
!-----------------------------------------------------------------------
real(kind=kfpt),parameter:: &
 wa=0.5 &                    ! weighting factor
,w1=wa*0.25 &                ! weighting factor
,w2=1.-wa                    ! weighting factor
!-----------------------------------------------------------------------
!MONARCH
integer(kind=kint),intent(in):: num_tracers_chem,num_aero,num_bc_chem
!MONARCH
integer(kind=kint),intent(in):: &
 lm &                        ! total # of levels
,lnsh                        ! blending area width, h points

real(kind=kfpt),intent(in):: &
 dt !&                        ! dynamics time step
!,pt                          ! pressure at the top

!real(kind=kfpt),dimension(1:lm),intent(in):: &
! dsg2 &                      ! delta sigmas
!,pdsg1                       ! delta pressures

!real(kind=kfpt),dimension(ims:ime,1:lnsh,1:2),intent(inout):: &
! pdbn &                      ! pressure difference at northern boundary
!,pdbs                        ! pressure difference at southern boundary

!real(kind=kfpt),dimension(1:lnsh,jms:jme,1:2),intent(inout):: &
! pdbe &                      ! pressure difference at eastern boundary
!,pdbw                        ! pressure difference at western boundary

real(kind=kfpt),dimension(ims:ime,1:lnsh,1:lm,1:2,1:num_bc_chem),intent(inout):: &
! tbn &                       ! temperature at northern boundary
!,tbs &                       ! temperature at southern boundary
 qbn &                       ! specific humidity at northern boundary
,qbs                        ! specific humidity at southern boundary
!,wbn &                       ! condensate at northern boundary
!,wbs                         ! condensate at southern boundary

real(kind=kfpt),dimension(1:lnsh,jms:jme,1:lm,1:2,1:num_bc_chem),intent(inout):: &
! tbe &                       ! temperature at eastern boundary
!,tbw &                       ! temperature at western boundary
 qbe &                       ! specific humidity at eastern boundary
,qbw                        ! specific humidity at western boundary
!,wbe &                       ! condensate at eastern boundary
!,wbw                         ! condensate at western boundary

!real(kind=kfpt),dimension(ims:ime,jms:jme),intent(inout):: &
! pd                          ! sigma range pressure difference

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm,1:num_tracers_chem),intent(inout):: &
! cw &                        ! condensate
 qchem !&                         ! specific humidity
!,t                           ! temperature

!real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm+1),intent(inout):: &
! pint                        ! pressure at interfaces
!-----------------------------------------------------------------------
!---local variables-----------------------------------------------------
!-----------------------------------------------------------------------
integer(kind=kint):: &
 i &                         ! index in x direction
,ib &                        ! index in x direction, boundary zone
,ihe &                       ! ending index in x direction, boundaries
,ihs &                       ! starting index in x direction, boundaries
,j &                         ! index in y direction
,jb &                        ! index in y direction, boundary zone
,jhe &                       ! ending index in x direction, boundaries
,jhs &                       ! starting index in x direction, boundaries
,k &                         ! boundary line counter
,ks &                        ! smoothing counter
,l &                         ! index in p direction
,lines &                     ! boundary smoothing area
,nsmud                       ! number of smoothing passes
!MONARCH
integer(kind=kint):: countchem !index number chemical species
!MONARCH

real(kind=kfpt),dimension(1:lnsh):: &
! wh(lnsh) &                  ! blending weighting function, temperature
 wq(lnsh)                    ! blending weighting function, moisture

!real(kind=kfpt),dimension(ims:ime,jms:jme):: &
! pdr                         ! pressure difference

real(kind=kfpt),dimension(ims:ime,jms:jme,1:lm):: &
! pr &                        ! pressure
q,qr !&                       ! specific humidity
!,tr                          ! temperature
!-----------------------------------------------------------------------
!***********************************************************************
!-----------------------------------------------------------------------
      lines=lnsh
      nsmud=lines-1
!-----------------------------------------------------------------------
!      wh(1)=1.
      wq(1)=1.
      do k=2,lnsh
!        wh(k)=exp(-(real(k)-1.)/(real(lnsh)-1.)*7.)
        wq(k)=exp(-(real(k)-1.)/(real(lnsh)-1.)*7.)
      enddo
!MONARCH
!CHEMICAL SPECIES COUNTER
   chemistry:do countchem = 1,num_bc_chem !3,3 !1,num_tracers_chem  !!!TEMPORAL PER O3
             q=qchem(:,:,:,GC_BCCHEM_MAP(countchem))
!-----------------------------------------------------------------------
!-------------update of boundary values at h points---------------------
!-----------------------------------------------------------------------
!-------------southern and northern boundary----------------------------
!-----------------------------------------------------------------------
      if(s_bdy)then
!        do jb=1,lnsh
!          do ib=its_h2,ite_h2 
!            pdbs(ib,jb,1)=pdbs(ib,jb,1)+pdbs(ib,jb,2)*dt
!          enddo
!        enddo
!
        do l=1,lm
          do jb=1,lnsh
            do ib=its_h2,ite_h2
!              tbs(ib,jb,l,1)=tbs(ib,jb,l,1)+tbs(ib,jb,l,2)*dt
              qbs(ib,jb,l,1,countchem)=qbs(ib,jb,l,1,countchem)+qbs(ib,jb,l,2,countchem)*dt
!              wbs(ib,jb,l,1)=wbs(ib,jb,l,1)+wbs(ib,jb,l,2)*dt
            enddo
          enddo
        enddo
      endif
!
      if(n_bdy)then
!        do jb=1,lnsh
!          do ib=its_h2,ite_h2
!            pdbn(ib,jb,1)=pdbn(ib,jb,1)+pdbn(ib,jb,2)*dt
!          enddo
!        enddo
!     
        do l=1,lm
          do jb=1,lnsh
            do ib=its_h2,ite_h2
!              tbn(ib,jb,l,1)=tbn(ib,jb,l,1)+tbn(ib,jb,l,2)*dt
              qbn(ib,jb,l,1,countchem)=qbn(ib,jb,l,1,countchem)+qbn(ib,jb,l,2,countchem)*dt
!              wbn(ib,jb,l,1)=wbn(ib,jb,l,1)+wbn(ib,jb,l,2)*dt
            enddo
          enddo
        enddo
      endif
!-----------------------------------------------------------------------
!-------------western and eastern boundary------------------------------
!-----------------------------------------------------------------------
      if(w_bdy)then
!        do jb=jts_h2,jte_h2
!          do ib=1,lnsh
!            pdbw(ib,jb,1)=pdbw(ib,jb,1)+pdbw(ib,jb,2)*dt
!          enddo
!        enddo
!
        do l=1,lm
          do jb=jts_h2,jte_h2
            do ib=1,lnsh
!              tbw(ib,jb,l,1)=tbw(ib,jb,l,1)+tbw(ib,jb,l,2)*dt
              qbw(ib,jb,l,1,countchem)=qbw(ib,jb,l,1,countchem)+qbw(ib,jb,l,2,countchem)*dt
!              wbw(ib,jb,l,1)=wbw(ib,jb,l,1)+wbw(ib,jb,l,2)*dt
            enddo
          enddo
        enddo
      endif
!
      if(e_bdy)then
!        do jb=jts_h2,jte_h2
!          do ib=1,lnsh
!            pdbe(ib,jb,1)=pdbe(ib,jb,1)+pdbe(ib,jb,2)*dt
!          enddo
!        enddo
!
        do l=1,lm
          do jb=jts_h2,jte_h2
            do ib=1,lnsh
!              tbe(ib,jb,l,1)=tbe(ib,jb,l,1)+tbe(ib,jb,l,2)*dt
              qbe(ib,jb,l,1,countchem)=qbe(ib,jb,l,1,countchem)+qbe(ib,jb,l,2,countchem)*dt
!              wbe(ib,jb,l,1)=wbe(ib,jb,l,1)+wbe(ib,jb,l,2)*dt
            enddo
          enddo
        enddo
      endif
!-----------------------------------------------------------------------
!-------------southern boundary-----------------------------------------
!-----------------------------------------------------------------------
      if(s_bdy)then
!        do j=1,lnsh
!          jb=j
!          ihs=jb
!          ihe=ide+1-jb
!          do i=max(its_h2,ihs),min(ite_h2,ihe)
!            ib=i
!            pd(i,j)=pdbs(ib,jb,1)*wh(jb)+pd(i,j)*(1.-wh(jb))
!            pint(i,j,1)=pt
!          enddo
!        enddo
!
        do l=1,lm
          do j=1,lnsh
            jb=j
            ihs=jb
            ihe=ide+1-jb
            do i=max(its_h2,ihs),min(ite_h2,ihe)
              ib=i
!              t(i,j,l)=tbs(ib,jb,l,1)*wh(jb)+t(i,j,l)*(1.-wh(jb))
              q(i,j,l)=qbs(ib,jb,l,1,countchem)*wq(jb)+q(i,j,l)*(1.-wq(jb))
!              cw(i,j,l)=wbs(ib,jb,l,1)*wq(jb)+cw(i,j,l)*(1.-wq(jb))
!              pint(i,j,l+1)=(pint(i,j,l) &
!                            +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(jb) &
!                           +pint(i,j,l+1)*(1.-wh(jb))
            enddo
          enddo
        enddo
      endif
!-----------------------------------------------------------------------
!-------------northern boundary-----------------------------------------
!-----------------------------------------------------------------------
      if(n_bdy)then
!        do j=jde-lnsh+1,jde
!          jb=j-jde+lnsh
!          ihs=1-jb+lnsh
!          ihe=ide+jb-lnsh
!          do i=max(its_h2,ihs),min(ite_h2,ihe)
!            ib=i
!            pd(i,j)=pdbn(ib,jb,1)*wh(lnsh+1-jb)+pd(i,j)*(1.-wh(lnsh+1-jb))
!            pint(i,j,1)=pt
!          enddo
!        enddo
!
        do l=1,lm
          do j=jde-lnsh+1,jde
            jb=j-jde+lnsh
            ihs=1-jb+lnsh
            ihe=ide+jb-lnsh
            do i=max(its_h2,ihs),min(ite_h2,ihe)
              ib=i
!              t(i,j,l)=tbn(ib,jb,l,1)*wh(lnsh+1-jb) &
!                      +t(i,j,l)*(1.-wh(lnsh+1-jb))
              q(i,j,l)=qbn(ib,jb,l,1,countchem)*wq(lnsh+1-jb) &
                      +q(i,j,l)*(1.-wq(lnsh+1-jb))
!              cw(i,j,l)=wbn(ib,jb,l,1)*wq(lnsh+1-jb) &
!                       +cw(i,j,l)*(1.-wq(lnsh+1-jb))
!              pint(i,j,l+1)=(pint(i,j,l) &
!                            +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(lnsh+1-jb) &                    
!                           +pint(i,j,l+1)*(1.-wh(lnsh+1-jb))
            enddo
          enddo
        enddo
      endif
!-----------------------------------------------------------------------
!-------------western boundary------------------------------------------
!-----------------------------------------------------------------------
      if(w_bdy)then
!        do i=1,lnsh
!          ib=i
!          jhs=1+ib
!          jhe=jde-ib
!          do j=max(jts_h2,jhs),min(jte_h2,jhe)
!            jb=j
!            pd(i,j)=pdbw(ib,jb,1)*wh(ib)+pd(i,j)*(1.-wh(ib))
!            pint(i,j,1)=pt
!          enddo
!        enddo
!
        do l=1,lm
          do i=1,lnsh
            ib=i
            jhs=1+ib
            jhe=jde-ib
            do j=max(jts_h2,jhs),min(jte_h2,jhe)
              jb=j
!              t(i,j,l)=tbw(ib,jb,l,1)*wh(ib)+t(i,j,l)*(1.-wh(ib))
              q(i,j,l)=qbw(ib,jb,l,1,countchem)*wq(ib)+q(i,j,l)*(1.-wq(ib))
!              cw(i,j,l)=wbw(ib,jb,l,1)*wq(ib)+cw(i,j,l)*(1.-wq(ib))
!              pint(i,j,l+1)=(pint(i,j,l) &
!                            +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(ib) &
!                           +pint(i,j,l+1)*(1.-wh(ib))
            enddo
          enddo
        enddo
      endif
!-----------------------------------------------------------------------
!-------------eastern boundary------------------------------------------
!-----------------------------------------------------------------------
      if(e_bdy)then
!        do i=ide+1-lnsh,ide
!          ib=i-ide+lnsh
!          jhs=2+lnsh-ib
!          jhe=jde-lnsh-1+ib
!          do j=max(jts_h2,jhs),min(jte_h2,jhe)
!            jb=j
!            pd(i,j)=pdbe(ib,jb,1)*wh(lnsh+1-ib)+pd(i,j)*(1.-wh(lnsh+1-ib))
!          enddo
!        enddo
!
        do l=1,lm
          do i=ide+1-lnsh,ide
            ib=i-ide+lnsh
            jhs=2+lnsh-ib
            jhe=jde-lnsh-1+ib
            do j=max(jts_h2,jhs),min(jte_h2,jhe)
              jb=j
!              t(i,j,l)=tbe(ib,jb,l,1)*wh(lnsh+1-ib) &
!                      +t(i,j,l)*(1.-wh(lnsh+1-ib))
              q(i,j,l)=qbe(ib,jb,l,1,countchem)*wq(lnsh+1-ib) &
                      +q(i,j,l)*(1.-wq(lnsh+1-ib))
!              cw(i,j,l)=wbe(ib,jb,l,1)*wq(lnsh+1-ib) &
!                       +cw(i,j,l)*(1.-wq(lnsh+1-ib))
!              pint(i,j,l+1)=(pint(i,j,l) &
!                            +(dsg2(l)*pd(i,j)+pdsg1(l)))*wh(lnsh+1-ib) &
!                           +pint(i,j,l+1)*(1.-wh(lnsh+1-ib))
            enddo
          enddo
        enddo
      endif
!
!-----------------------------------------------------------------------
!***  The four corner points.
!-----------------------------------------------------------------------
!
      if(s_bdy.and.w_bdy)then
!        pd(its+1,jts+1)=(pd(its+1,jts)+pd(its,jts+1) &
!                        +pd(its+2,jts+1)+pd(its+1,jts+2))*0.25
        do l=1,lm
!          t(its+1,jts+1,l)=(t(its+1,jts,l)+t(its,jts+1,l) &
!                           +t(its+2,jts+1,l)+t(its+1,jts+2,l))*0.25
          q(its+1,jts+1,l)=(q(its+1,jts,l)+q(its,jts+1,l) &
                           +q(its+2,jts+1,l)+q(its+1,jts+2,l))*0.25
!          cw(its+1,jts+1,l)=(cw(its+1,jts,l)+cw(its,jts+1,l) &
!                           + cw(its+2,jts+1,l)+cw(its+1,jts+2,l))*0.25
        enddo
      endif
!       
      if(s_bdy.and.e_bdy)then
!        pd(ite-1,jts+1)=(pd(ite-1,jts)+pd(ite-2,jts+1) &
!                        +pd(ite,jts+1)+pd(ite-1,jts+2))*0.25
        do l=1,lm
!          t(ite-1,jts+1,l)=(t(ite-1,jts,l)+t(ite-2,jts+1,l) &
!                           +t(ite,jts+1,l)+t(ite-1,jts+2,l))*0.25
          q(ite-1,jts+1,l)=(q(ite-1,jts,l)+q(ite-2,jts+1,l) &
                           +q(ite,jts+1,l)+q(ite-1,jts+2,l))*0.25
!          cw(ite-1,jts+1,l)=(cw(ite-1,jts,l)+cw(ite-2,jts+1,l) &
!                            +cw(ite,jts+1,l)+cw(ite-1,jts+2,l))*0.25
        enddo
      endif
!
      if(n_bdy.and.w_bdy)then
!        pd(its+1,jte-1)=(pd(its+1,jte-2)+pd(its,jte-1) &
!                        +pd(its+2,jte-1)+pd(its+1,jte))*0.25
        do l=1,lm
!          t(its+1,jte-1,l)=(t(its+1,jte-2,l)+t(its,jte-1,l) &
!                           +t(its+2,jte-1,l)+t(its+1,jte,l))*0.25
          q(its+1,jte-1,l)=(q(its+1,jte-2,l)+q(its,jte-1,l) &
                           +q(its+2,jte-1,l)+q(its+1,jte,l))*0.25
!          cw(its+1,jte-1,l)=(cw(its+1,jte-2,l)+cw(its,jte-1,l) &
!                            +cw(its+2,jte-1,l)+cw(its+1,jte,l))*0.25
        enddo
      endif
!
      if(n_bdy.and.e_bdy)then
!        pd(ite-1,jte-1)=(pd(ite-1,jte-2)+pd(ite-2,jte-1) &
!                        +pd(ite,jte-1)+pd(ite-1,jte))*0.25
        do l=1,lm
!          t(ite-1,jte-1,l)=(t(ite-1,jte-2,l)+t(ite-2,jte-1,l) &
!                           +t(ite,jte-1,l)+t(ite-1,jte,l))*0.25
          q(ite-1,jte-1,l)=(q(ite-1,jte-2,l)+q(ite-2,jte-1,l) &
                           +q(ite,jte-1,l)+q(ite-1,jte,l))*0.25
!          cw(ite-1,jte-1,l)=(cw(ite-1,jte-2,l)+cw(ite-2,jte-1,l) &
!                            +cw(ite,jte-1,l)+cw(ite-1,jte,l))*0.25
        enddo
      endif
!
!-----------------------------------------------------------------------
!
!      if(s_bdy)then
!        do j=jts,jts+1
!          do i=its_h2,ite_h2
!            pint(i,j,1)=pt
!          enddo
!        enddo
!
!        do l=1,lm
!          do j=jts,jts+1
!            do i=its_h2,ite_h2
!              pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l))
!            enddo
!          enddo
!        enddo
!      endif
!!
!      if(n_bdy)then
!        do j=jte-1,jte
!          do i=its_h2,ite_h2
!            pint(i,j,1)=pt
!          enddo
!        enddo
!!
!        do l=1,lm
!          do j=jte-1,jte
!            do i=its_h2,ite_h2
!              pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l))
!            enddo
!          enddo
!        enddo             
!      endif
!!
!      if(w_bdy)then
!        do j=jts_h2,jte_h2
!          do i=its,its+1
!            pint(i,j,1)=pt
!          enddo
!        enddo
!!
!        do l=1,lm
!          do j=jts_h2,jte_h2
!            do i=its,its+1
!              pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l))
!            enddo
!          enddo
!        enddo
!      endif
!!
!      if(e_bdy)then
!        do j=jts_h2,jte_h2
!          do i=ite-1,ite
!            pint(i,j,1)=pt
!          enddo
!        enddo
!!
!        do l=1,lm
!          do j=jts_h2,jte_h2
!            do i=ite-1,ite
!              pint(i,j,l+1)=pint(i,j,l)+(dsg2(l)*pd(i,j)+pdsg1(l))
!            enddo
!          enddo
!        enddo
!      endif
!-----------------------------------------------------------------------
!
      if(nsmud>=1)then
!
        smooth: do ks=1,nsmud
!-----------------------------------------------------------------------
          if(s_bdy)then
!            do j=jts+1,jts-1+lines
!              do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                pdr(i,j)=(pd(i,j-1)+pd(i-1,j) &
!                         +pd(i+1,j)+pd(i,j+1))*w1+w2*pd(i,j)       
!              enddo
!            enddo
!
            do l=1,lm
              do j=jts+1,jts-1+lines
                do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                  tr(i,j,l)=(t(i,j-1,l)+t(i-1,j,l) &
!                            +t(i+1,j,l)+t(i,j+1,l))*w1 &
!                            +w2*t(i,j,l)       
                  qr(i,j,l)=(q(i,j-1,l)+q(i-1,j,l) &
                            +q(i+1,j,l)+q(i,j+1,l))*w1 &
                            +w2*q(i,j,l)
!                  pr(i,j,l)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) &
!                            +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 &
!                            +w2*pint(i,j,l+1)       
                enddo
              enddo
            enddo
          endif
!
          if(n_bdy)then
!            do j=jte-lines+1,jte-1
!              do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                pdr(i,j)=(pd(i,j-1)+pd(i-1,j) &
!                         +pd(i+1,j)+pd(i,j+1))*w1+w2*pd(i,j)       
!              enddo
!            enddo
!
            do l=1,lm
              do j=jte-lines+1,jte-1
                do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                  tr(i,j,l)=(t(i,j-1,l)+t(i-1,j,l) &
!                            +t(i+1,j,l)+t(i,j+1,l))*w1 &
!                            +w2*t(i,j,l)       
                  qr(i,j,l)=(q(i,j-1,l)+q(i-1,j,l) &
                            +q(i+1,j,l)+q(i,j+1,l))*w1 &
                            +w2*q(i,j,l)
!                  pr(i,j,l)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) &
!                            +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 &
!                            +w2*pint(i,j,l+1)       
                enddo
              enddo
            enddo
          endif
!
          if(w_bdy)then
!            do j=max(jts_h2,jds+lines),min(jte_h2,jde-lines)
!              do i=its+1,its-1+lines
!                pdr(i,j)=(pd(i,j-1)+pd(i-1,j) &
!                         +pd(i+1,j)+pd(i,j+1))*w1+w2*pd(i,j)       
!              enddo
!            enddo
!               
            do l=1,lm
              do j=max(jts,jds+lines),min(jte,jde-lines)
                do i=its+1,its-1+lines
!                  tr(i,j,l)=(t(i,j-1,l)+t(i-1,j,l) &
!                            +t(i+1,j,l)+t(i,j+1,l))*w1 &
!                            +w2*t(i,j,l)       
                  qr(i,j,l)=(q(i,j-1,l)+q(i-1,j,l) &
                            +q(i+1,j,l)+q(i,j+1,l))*w1 &
                            +w2*q(i,j,l)
!                  pr(i,j,l)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) &
!                            +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 &
!                            +w2*pint(i,j,l+1)       
                enddo
              enddo
            enddo
          endif
!
          if(e_bdy)then
!            do j=max(jts_h2,jds+lines),min(jte_h2,jde-lines)
!              do i=ite-lines+1,ite-1
!                pdr(i,j)=(pd(i,j-1)+pd(i-1,j) &
!                         +pd(i+1,j)+pd(i,j+1))*w1+w2*pd(i,j)       
!              enddo
!            enddo
!
            do l=1,lm
              do j=max(jts_h2,jds+lines),min(jte_h2,jde-lines)
                do i=ite-lines+1,ite-1
!                  tr(i,j,l)=(t(i,j-1,l)+t(i-1,j,l) &
!                            +t(i+1,j,l)+t(i,j+1,l))*w1 &
!                            +w2*t(i,j,l)       
                  qr(i,j,l)=(q(i,j-1,l)+q(i-1,j,l) &
                            +q(i+1,j,l)+q(i,j+1,l))*w1 &
                            +w2*q(i,j,l)
!                  pr(i,j,l)=(pint(i,j-1,l+1)+pint(i-1,j,l+1) &
!                            +pint(i+1,j,l+1)+pint(i,j+1,l+1))*w1 &
!                            +w2*pint(i,j,l+1)       
                enddo
              enddo
            enddo
          endif
!-----------------------------------------------------------------------
          if(s_bdy)then
!            do j=jts+1,jts-1+lines
!              do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                pd(i,j)=pdr(i,j)
!              enddo
!            enddo
!
            do l=1,lm
              do j=jts+1,jts-1+lines
                do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                  t(i,j,l)=tr(i,j,l)
                  q(i,j,l)=qr(i,j,l)
!                  pint(i,j,l+1)=pr(i,j,l)
                enddo
              enddo
            enddo
          endif
!
          if(n_bdy)then
!            do j=jte-lines+1,jte-1
!              do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                pd(i,j)=pdr(i,j)
!              enddo
!            enddo
!
            do l=1,lm
              do j=jte-lines+1,jte-1
                do i=max(its_h2,ids+1),min(ite_h2,ide-1)
!                  t(i,j,l)=tr(i,j,l)
                  q(i,j,l)=qr(i,j,l)
!                  pint(i,j,l+1)=pr(i,j,l)
                enddo
              enddo
            enddo
          endif
!         
          if(w_bdy)then
!            do j=max(jts_h2,jds+lines),min(jte_h2,jde-lines)
!              do i=its+1,its-1+lines
!                pd(i,j)=pdr(i,j)
!              enddo
!            enddo
!
            do l=1,lm
              do j=max(jts_h2,jds+lines),min(jte_h2,jde-lines)
                do i=its+1,its-1+lines
!                  t(i,j,l)=tr(i,j,l)
                  q(i,j,l)=qr(i,j,l)
!                  pint(i,j,l+1)=pr(i,j,l)
                enddo
              enddo
            enddo
          endif
!
          if(e_bdy)then
!            do j=max(jts_h2,jds+lines),min(jte_h2,jde-lines)
!              do i=ite-lines+1,ite-1
!                pd(i,j)=pdr(i,j)
!              enddo
!            enddo
!
            do l=1,lm
              do j=max(jts_h2,jds+lines),min(jte_h2,jde-lines)
                do i=ite-lines+1,ite-1
!                  t(i,j,l)=tr(i,j,l)
                  q(i,j,l)=qr(i,j,l)
!                  pint(i,j,l+1)=pr(i,j,l)
                enddo
              enddo
            enddo
          endif
!-----------------------------------------------------------------------
        enddo smooth
!
      endif
!MONARCH
!-----------------------------------------------------------------------
           qchem(:,:,:,GC_BCCHEM_MAP(countchem))=q
      enddo chemistry
!MONARCH
!-----------------------------------------------------------------------
!             
                        endsubroutine bocoh_chem
!
!-----------------------------------------------------------------------
!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!----------------------------------------------------------------------
!
                        end module module_bsc_dynamics_routines_chem
!
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------

