!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
!                     version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software 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 above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!

      subroutine sptruncr(psp,cdtype,ktrunc,cdpart,knk) 3
!
!s/r sptruncr: Filter spectral array of RPN 2D-FFT according to a given truncation type.
!
! AUTHOR: Luc Fillion - MSC/CAN - 20 Apr 2005.
!
! Revision: Luc Fillion - EC/CAN - 20 May 2007. - Include windowing.
! Revision: Luc Fillion - EC/CAN - 29 oct 2007. - Allow low or high wvnb filtering via cdpart.
! Revision: Luc Fillion - EC/CAN - 26 May 2010. - Simple update at level v_11_01b.
!
! IN/OUT:
!   psp:
! IN:
!   cdtype: Truncation type: 'T': triangular; 'E': Elliptic.
!
      IMPLICIT  NONE
!
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comcst.cdk"
#include "comfftla.cdk"
#include "comlun.cdk"
!
      integer knk,ktrunc
      real*8 psp(nla,2,knk)
      character*1 cdtype
      character*1 cdpart
!
      character*3 clwindow
      integer jband,jm,ila,jla,itruncx,itruncy,jk,iband,iwidth
      integer iflag(nla),itrunc
      real*8 zratiox,zratioy,zpio2,ztrunc,zdiff,zwidth,zwvnbtot
      real*8 zweight(nband)
!
!!
      zpio2 = rpi/2.
!
      itrunc = ktrunc
      ztrunc = real(ktrunc)
      clwindow = 'COS'  ! cos
      iwidth = min(itrunc,10)
      zwidth = real(iwidth)
!
      zweight(:) = 1.0
!
      do jband = 1, nband
        zweight(jband) = 1.0
        zwvnbtot = real(wvnbtot(jband))
        if(clwindow.eq.'COS') then
          if(cdpart.eq.'H') then
            zdiff = zwvnbtot-ztrunc
            if(zdiff.gt.0) then
              zweight(jband) = 0.0
              if(zdiff.lt.zwidth) then
                zweight(jband) = cos(zdiff/zwidth*zpio2)**2
              endif
            endif
          else if(cdpart.eq.'L') then
            zdiff = zwvnbtot-ztrunc
            if(zdiff.lt.0) then
              zweight(jband) = 0.0
              if(abs(zdiff).lt.zwidth) then
                zweight(jband) = 1.0-sin(zdiff/zwidth*zpio2)**2
              endif
            endif
          endif
        else if(clwindow.eq.'HAT') then
          if(cdpart.eq.'H') then
            if(wvnbtot(jband).gt.itrunc) then
              zweight(jband) = 0.0
            endif
          else if(cdpart.eq.'L') then
            if(wvnbtot(jband).lt.itrunc) then
              zweight(jband) = 0.0
            endif
          endif
        endif
!          write(nulout,*) 'sptruncr: jband,zweight(jband)=',jband,zweight(jband)
      enddo
!
      itruncx=itrunc
      itruncy=itrunc
!
      if(cdtype.eq.'E') then
        do jk=1,knk
          do jla=1,nla
            zratiox = (mwvnbx(jla)/itruncx)**2
            zratioy = (mwvnby(jla)/itruncy)**2
            if((zratiox+zratioy).gt.1.0) then
              psp(jla,1,jk)=0.0
              psp(jla,2,jk)=0.0
            endif
          enddo
        enddo
      else if(cdtype.eq.'T') then
        do jk = 1, knk
          do jla = 1, nla
            iflag(jla) = 0
          enddo
          do jband = 1, nband
            do jm = 1, mbandsp(jband)
              ila = mila(jm,jband)  ! locate spectral elements in the rectangle not in a defined band
              iflag(ila) = 1
              psp(ila,1,jk)=zweight(jband)*psp(ila,1,jk)
              psp(ila,2,jk)=0.0
!              psp(ila,2,jk)=zweight(jband)*psp(ila,2,jk)
            enddo
          enddo
!
          do jla = 1, nla
            if(iflag(jla).eq.0) then
              psp(jla,1,jk)=0.0
              psp(jla,2,jk)=0.0
            endif
          enddo
        enddo  ! jk loop
      endif
!
      return
      end