!-------------------------------------- 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 v_gaspar(pcorr,pprof,plength) 12,1
!
        IMPLICIT NONE
#if defined (DOC)
*
***s/r  v_gaspar - Generate a vertical Gaspari_Cohn Localization matrix.
*              Based on approach used in sucorns2.ftn following Mark Buehner's code.
*
*Author  : Luc Fillion - ARMA/EC - 17 Feb 2009.
*Revision:
*
#endif
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcorr.cdk"
#include "comcva.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
#include "comspg.cdk"
#include "rpnstd.cdk"
*
      real*8 plength
      real*8 pcorr(nflev,nflev)
      real*8 pprof(nflev)  ! pressure profile (Pa)
!
      integer jk1,jk2
      real*8 zps,zlc,zr,zpres1,zpres2,zfac,zpstrato,zlength
!
!!
      zpstrato = 0.0
!      zpstrato = log(10.e2)   ! 10 hPa
!
      do jk1=1,nflev
        write(nulout,*)'v_gaspar:lev,hyb,pprof,log= ',jk1,vhybinc(jk1)
     &              ,pprof(jk1),log(pprof(jk1))
      enddo
!
! calculate 5'th order function (from Gaspari and Cohn)
!
      if(plength.gt.0.0) then
        do jk1=1,nflev
          zpres1=log(pprof(jk1))
          if(zpres1.lt.zpstrato) then
            zfac = 1./log(zpstrato/zpres1)
          else
            zfac = 1.0
          endif
          zlength = zfac*plength
          do jk2=1,nflev
            zlc=zlength/2.0
            zpres2=log(pprof(jk2))
            zr = abs(zpres2 - zpres1)
            if(zr.le.zlc) then
              pcorr(jk1,jk2)=-0.250*(ZR/ZLC)**5+0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3-(5.0/3.0)*(ZR/ZLC)**2+1.0
            elseif(ZR.le.(2.0*ZLC)) then
              pcorr(jk1,jk2)=(1.0/12.0)*(ZR/ZLC)**5-0.5*(ZR/ZLC)**4
     +                +0.625*(ZR/ZLC)**3+(5.0/3.0)*(ZR/ZLC)**2
     +                -5.0*(ZR/ZLC)+4.0-(2.0/3.0)*(ZLC/ZR)
            else
              pcorr(jk1,jk2)= 0.0
            endif
            if(pcorr(jk1,jk2).lt.0.0) pcorr(jk1,jk2)=0.0
          enddo
        enddo
      else
        write(nulout,*) 'v_gaspar: plength = ',plength
        call abort3d(nulout,'v_gaspar: plength must be > 0.0 ')
      endif
!
      return
      end