c-----------------------------------------------------------------------
      subroutine shap_vec(nstep,npt,nz,uc,vc,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
c-----------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      dimension uc(npt,1),vc(npt,1),tp(1)
      dimension lxxk(MXBDY,nz),lyxk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *          ifxk(9*MAXSID,nz), ifpxk(5*MAXSID,nz), ifyk(9*MAXSID,nz)
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +         ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      logical NOSLIP
      common /new_shap/nordu,nshapu,mshapu,dshapu, nordh,nshaph,mshaph,dshaph
     *               , nordp,nshapp,mshapp,dshapp
     *               , nordd,nshapd,mshapd,dshapd,dshapv
      common/param0/iyear,iday,isec,delt,ncyc,mbc,nonlin,label(20),
     +              itherm,mlc,limp
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      external shap_1drn, shap_1dro, shap_1dcn

      if (mshapu .eq. 0) return

      if (nstep.eq.0 .or. (nshapu.ne.0 .and. mod(nstep,nshapu).eq.0)) then
         NOSLIP = (mbc .eq. 1)
         do k = 1, nz
            npk = nptk(k) 
            nbx = nbxk(k) 
            nby = nbyk(k) 
            nfx = nfxk(k) 
            nfpx = nfpxk(k) 
            nfy = nfyk(k) 
            if     (mshapu .eq. 1) then
c........use NEW reduce order filter near BC & in NARROW passages: 
               call shap_2d (nordu,.true.,.true.,NOSLIP,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1drn,dshapu)
               call shap_2d (nordu,.true.,NOSLIP,.true., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1drn,dshapu)
            elseif (mshapu .eq. 2) then
c........use NEW reduce order filter near BC only:
               call shap_2d (nordu,.false.,.true.,NOSLIP,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1drn,dshapu)
               call shap_2d (nordu,.false.,NOSLIP,.true., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1drn,dshapu)
            elseif (mshapu .eq. 3) then
c........use OLD reduce order filter near BC & in NARROW passages: 
               call shap_2d (nordu,.true.,.true.,NOSLIP,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1dro,dshapu)
               call shap_2d (nordu,.true.,NOSLIP,.true., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1dro,dshapu)
            elseif (mshapu .eq. 4) then
c........conservative filters
               call shap_2d (nordu,.false.,.false.,.false.,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1dcn,dshapu)
               call shap_2d (nordu,.false.,.false.,.false.,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1dcn,dshapu)
            endif
         enddo
      endif
            
      return
      end

c-----------------------------------------------------------------------
      subroutine shap_scl(nstep,npt,nz,nz1,nz2,tem,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
c-----------------------------------------------------------------------
 
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      dimension tem(npt,nz), tp(1)
      dimension lxxk(MXBDY,nz),lyxk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *          ifxk(9*MAXSID,nz), ifpxk(5*MAXSID,nz), ifyk(9*MAXSID,nz)

      common /new_shap/nordu,nshapu,mshapu,dshapu, nordh,nshaph,mshaph,dshaph
     *               , nordp,nshapp,mshapp,dshapp
     *               , nordd,nshapd,mshapd,dshapd,dshapv
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +         ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      external shap_1dco, shap_1dcn

      if (mshaph .le. 0) return

      if (nstep.eq.0 .or. (nshaph.ne.0 .and. mod(nstep,nshaph).eq.0))  then
         do k = nz1, nz2
            npk = nptk(k) 
            nbx = nbxk(k) 
            nby = nbyk(k) 
            nfx = nfxk(k) 
            nfpx = nfpxk(k) 
            nfy = nfyk(k) 
            if     (mshaph .eq. 1) then
c........use NEW conservative filter: 
               call shap_2d (nordh, .false., .false.,.false., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            elseif (mshaph .eq. 2) then
c........use NEW conservative filter & REDUCE order in NARROW passages: 
               call shap_2d (nordh, .true., .false.,.false., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            elseif (mshaph .eq. 3) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordh, 3, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dco,dshaph)
            elseif (mshaph .eq. 5) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordh, 3, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            elseif (mshaph .eq. 6) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordh, 4, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            endif
         enddo
      endif
         

      return
      end

c--------------------------------------------------------------------------
      subroutine shap_2d (nord,REDUC,SETX,SETY,npt,lxx,lyx,isy,isk,
     *                     ifx,ifpx,ify, aa,abc,filter,scoef)
c--------------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension lxx(1),lyx(1),isy(1),isk(1), aa(1), bb(1), cc(1), abc(npt,1)
      dimension ifx(3,1), ifpx(5,1), ify(3,1) 
      logical SETX, SETY, ZER, REDUC 
      pointer (pbb, bb), (pcc, cc)
      external filter

      common /shap_c25/ cs25(10), ZER, s_coef
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      s_coef = scoef

c sizeof(abc) = 3*npt

      pbb = loc(abc(1,1))
      pcc = loc(abc(1,2))

c.......apply Shapiro filter in X direction
      do i = 1, npt
         bb(i) = aa(isk(i))
      enddo

      ZER = SETX   ! used only if filter = shap_1do
      nshap = MAXFO
      do k = 1, nfx
         if (REDUC) nshap = min(nord, ifx(3,k))
         call filter (nshap, ifx(2,k), bb(ifx(1,k)), cc)
      enddo

      do k = 1, nfpx
         if (REDUC) nshap = min(nord, ifpx(5,k))
         if (ifpx(4,k) .eq. 0) then
            call shap_1dp0 (nshap, ifpx(2,k), bb(ifpx(1,k)), cc)
         else
            call shap_1dper (nshap, ifpx(1,k), bb, cc, filter)
         endif
      enddo

      do i = 1, npt
         cc(isk(i)) = bb(i)
      enddo
      
      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo
      
c.......apply Shapiro filter in Y direction
      do i = 1, npt
         bb(i) = aa(isy(i))
      enddo

      ZER = SETY 
      do k = 1, nfy
         if (REDUC) nshap = min(nord, ify(3,k))
         call filter (nshap, ify(2,k), bb(ify(1,k)), cc)
      enddo

      do i = 1, npt
         cc(isy(i)) = bb(i)
      enddo

      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo

      return
      end

c--------------------------------------------------------------------------
      subroutine shap_2dlim (nord,key,SETX,SETY,npt,lxx,lyx,isy,isk,
     *                       ifx,ifpx,ify, aa,abc,filter,scoef)
c--------------------------------------------------------------------------
c.....reduces order for all points on short segments
c                 length=4   -> nshap = 1
c                 length=5,6 -> nshap = min(2,nord)
c                 length=7,8 -> nshap = min(3,nord)
c                  etc.
c.....but if nshap <= LIM_SHAP, then DON'T FILTER segment at all

      implicit real(a-h,o-z),integer(i-n)
      dimension lxx(1),lyx(1),isy(1),isk(1), aa(1), bb(1), cc(1), abc(npt,1)
      dimension ifx(3,1), ifpx(5,1), ify(3,1)
      logical SETX, SETY, ZER, REDUC 
      pointer (pbb, bb), (pcc, cc)
      external filter

      common /shap_c25/ cs25(10), ZER, s_coef
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      s_coef = scoef
      LIM_SHAP = key - 2

c sizeof(abc) = 3*npt

      pbb = loc(abc(1,1))
      pcc = loc(abc(1,2))

c.....use a reduced order filter in a narrow passages.
c
c.......apply Shapiro filter in X direction
      do i = 1, npt
         bb(i) = aa(isk(i))
      enddo

      ZER = SETX
      do k = 1, nfx
         nshap = min(nord, ifx(3,k))
         if (nshap .gt. LIM_SHAP) then
            call filter (nshap, ifx(2,k), bb(ifx(1,k)), cc)
         else
            call zero_em (ifx(2,k), bb(ifx(1,k)))
         endif
      enddo

      do k = 1, nfpx
         nshap = min(nord, ifpx(5,k))
         if (nshap .gt. LIM_SHAP) then
            if (ifpx(4,k) .eq. 0) then
               call shap_1dp0 (nshap, ifpx(2,k), bb(ifpx(1,k)), cc)
            else
               call shap_1dper (nshap, ifpx(1,k), bb, cc, filter)
            endif
         else
            call zero_em (ifpx(2,k), bb(ifpx(1,k)))
            call zero_em (ifpx(4,k), bb(ifpx(3,k)))
         endif
      enddo

      do i = 1, npt
         cc(isk(i)) = bb(i)
      enddo

      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo
      
c.......apply Shapiro filter in Y direction

      do i = 1, npt
         bb(i) = aa(isy(i))
      enddo

      ZER = SETY

      do k = 1, nfy
         nshap = min(nord, ify(3,k))
         if (nshap .gt. LIM_SHAP) then 
            call filter (nshap, ify(2,k), bb(ify(1,k)), cc)
         else
            call zero_em (ify(2,k), bb(ify(1,k)))
         endif
      enddo

      do i = 1, npt
         cc(isy(i)) = bb(i)
      enddo

      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo

      return
      end
      
      subroutine shap_1drn (nshap, nn, f, tmp)
c----------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), cc(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pcc, cc), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef
      
      paa = loc(f(1))
      pbb = loc(tmp(1))
      pcc = loc(tmp(nn+1))

      do n = 1, nshap
         const = s_coef*cs25(n)
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         if (n .eq. 1) then
            if (ZER) then
               aa(1)  = 0.
               aa(nn) = 0.
            else
               aa(1)  = -aa(2)
               aa(nn) = -aa(nn-1)
            endif
         elseif (.not. ZER) then
            aa(n)      = -aa(n+1)
            aa(nn-n+1) = -aa(nn-n)
         endif

         cc(n)      = const*aa(n)
         cc(nn-n+1) = const*aa(nn-n+1)
      enddo

      do i = nshap+1, nn-nshap
         f(i) = const*aa(i)
      enddo

      do i = 1, nshap
         f(i)      = cc(i)
         f(nn-i+1) = cc(nn-i+1)
      enddo

      return
      end

      subroutine shap_1dro (nshap, nn, f, tmp)
c----------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), cc(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pcc, cc), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef
      
      paa = loc(f(1))
      pbb = loc(tmp(1))
      pcc = loc(tmp(nn+1))

      do n = 1, nshap
         const = s_coef*cs25(n)
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         if (n .eq. 1) then
            if (ZER) then
               aa(1)  = 0.
               aa(nn) = 0.
            else
               aa(1)  = bb(1)  - bb(2) 
               aa(nn) = bb(nn) - bb(nn-1)
            endif
         endif

         cc(n)      = const*aa(n)
         cc(nn-n+1) = const*aa(nn-n+1)
      enddo

      do i = nshap+1, nn-nshap
         f(i) = const*aa(i)
      enddo

      do i = 1, nshap
         f(i)      = cc(i)
         f(nn-i+1) = cc(nn-i+1)
      enddo

      return
      end

      subroutine shap_1dper (nshap, id, f, tmp, filter)
c------------------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension id(4), f(1), tmp(1), aa(1), bb(1)
      pointer (paa, aa), (pbb, bb)
      external filter

      i1 = id(1)
      n1 = id(2)

      i2 = id(3)
      n2 = id(4)
      n12 = n1 + n2

      paa = loc(f(i2))
      do i = 1, n2
         tmp(i) = aa(i) 
      enddo
      paa = loc(f(i1))
      k = n2
      do i = 1, n1
         k = k + 1
         tmp(k) = aa(i) 
      enddo
      
      call filter (nshap, n12, tmp, tmp(n12+1))
      
      k = n2
      do i = 1, n1
         k = k + 1
         aa(i) = tmp(k) 
      enddo
      paa = loc(f(i2))
      do i = 1, n2
         aa(i) = tmp(i) 
      enddo

      return
      end

      subroutine shap_1dcn (nshap, nn, f, tmp)
c---------------------------------------------      
c suppose to be an old key=6 case
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         aa(1)  = -aa(2)
         aa(nn) = -aa(nn-1)
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end

      subroutine shap_1dco (nshap, nn, f, tmp)
c---------------------------------------------      
c suppose to be an old key=6 case
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         aa(1)  = bb(1)  - bb(2)
         aa(nn) = bb(nn) - bb(nn-1)
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end

      subroutine shap_1dp0 (nshap, nn, f, tmp)
c---------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f1 = bb(1)
         f2 = bb(2)
         f0 = f1
         fp = f2
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         aa(1)  = (f1 - f2) + (f1 - fp)
         aa(nn) = (fp - f1) + (fp - f0)
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end

      subroutine shap_1dc (nshap, nn, f, tmp)
c---------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
      enddo

      al = -aa(1+nshap)
      ar = -aa(nn-nshap)
      do i = nshap, 1, -1 
         aa(i)      = al
         aa(nn-i+1) = ar
         al = -al
         ar = -ar
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end

c-----------------------------------------------------------------------
      subroutine shap_dens(nstep,npt,nz,nz1,nz2,tem,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
c-----------------------------------------------------------------------
 
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      dimension tem(npt,nz), tp(1)
      dimension lxxk(MXBDY,nz),lyxk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *          ifxk(9*MAXSID,nz), ifpxk(5*MAXSID,nz), ifyk(9*MAXSID,nz)

      common /new_shap/nordu,nshapu,mshapu,dshapu, nordh,nshaph,mshaph,dshaph
     *               , nordp,nshapp,mshapp,dshapp
     *               , nordd,nshapd,mshapd,dshapd,dshapv
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +         ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      external shap_1dco, shap_1dcn

      if (mshapd .le. 0) return

      if (nstep.eq.0 .or. (nshapd.ne.0 .and. mod(nstep,nshapd).eq.0))  then
         do k = nz1, nz2
            npk = nptk(k) 
            nbx = nbxk(k) 
            nby = nbyk(k) 
            nfx = nfxk(k) 
            nfpx = nfpxk(k) 
            nfy = nfyk(k) 
            if     (mshapd .eq. 1) then
c........use NEW conservative filter: 
               call shap_2d (nordd, .false., .false.,.false., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshapd)
            elseif (mshapd .eq. 2) then
c........use NEW conservative filter & REDUCE order in NARROW passages: 
               call shap_2d (nordd, .true., .false.,.false., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshapd)
            elseif (mshapd .eq. 3) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordd, 3, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dco,dshapd)
            elseif (mshapd .eq. 5) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordd, 3, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshapd)
            elseif (mshapd .eq. 6) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordd, 4, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshapd)
            endif
         enddo
      endif
         

      return
      end

