!-------------------------------------- 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_glb(psp,cdtype,ktrunc,cdpart,knk) 1
!
!s/r ptruncr_glb: For global system: Filter spectral array according to a given truncation type.
!
! AUTHOR: Luc Fillion - EC/CAN - 20 Oct 2008.
!
! Revision: 
!
! IN/OUT:
!   psp:
! IN:
!   cdtype: Truncation type: 'T': triangular; 'E': Elliptic.
!
      IMPLICIT  NONE
!
#include "taglam4d.cdk"
#include "comdim.cdk"
#include "comcst.cdk"
#include "comlun.cdk"
#include "comleg.cdk"
!
      integer knk,ktrunc
      real*8 psp(nla,2,knk)
      character*1 cdtype
      character*1 cdpart
!
      character*3 clwindow
      integer jn,jm,ila,jla,jk,iwidth,im
      integer iflag(nla)
      real*8 zpio2,ztrunc,zwvnbtot,zdiff,zwidth
      real*8 zweight(ntrunc)
!
!!
      zpio2 = rpi/2.
      ztrunc = real(ktrunc)
      clwindow = 'COS'
!
      zweight(:) = 1.0
      iwidth = min(ktrunc,10)
      zwidth = real(iwidth)
!
      if(clwindow.eq.'COS') then
        if(cdpart.eq.'H') then
          do jn = 0, ntrunc
            zwvnbtot = real(jn)
            zdiff = zwvnbtot-ztrunc
            if(zdiff.gt.0.and.zdiff.lt.zwidth) then
              zweight(jn) = cos(zdiff/zwidth*zpio2)**2
            else
              zweight(jn) = 0.0
            endif
          enddo
        else if(cdpart.eq.'L') then
          do jn = 0, ntrunc
            zwvnbtot = real(jn)
            zdiff = zwvnbtot-ztrunc
            if(zdiff.lt.0) then
              if(abs(zdiff).lt.zwidth) then
                zweight(jn) = sin(zdiff/zwidth*zpio2)**2
              else
                zweight(jn) = 0.0
              endif
            endif
          enddo
        endif
      endif
!
      do jm = 0, ntrunc
        im=jm
        if(jm.eq.0) im=1
        do jn = im, ntrunc
          ila = nind(jm) + jn - jm
          do jk=1,knk
            psp(ila,1,jk)=zweight(jn)*psp(ila,1,jk)
            psp(ila,2,jk)=zweight(jn)*psp(ila,2,jk)
          enddo
        enddo
      enddo
!
      return
      end