!-------------------------------------- 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 ecr_gu(pin,cdvar,kniter,cdetiket,kunit,kni,knj,knk) 17,4
#if defined (DOC)
*
***s/r ecr_gu  - Write global background error st-dev on RPN
*    .             standard file
*
*Author  : L. Fillion - ARMA/EC - Feb 2007.
*Revision: 
*
* Luc Fillion - ARMA/EC - Sept 09: Add output of zonal fields.

*Arguments
*
#endif
C
      IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "compost.cdk"
#include "cvcord.cdk"
#include "rpnstd.cdk"
#include "comgdpar.cdk"
#include "cominterp.cdk"
#include "comct0.cdk"
#include "comfilt.cdk"
#include "comgd0.cdk"
#include "comsim.cdk"
#include "compdg.cdk"
#include "comspg.cdk"
#include "comcorr.cdk"
#include "comin.cdk"
*
      character*3 cdvar
      integer nvar,kni,knj,knk,kniter,kunit
      parameter (nvar=8)
      character*8 cdetiket
      real*8 pin(kni,knj,knk)
!
      logical lladiab,llconv,llcond,lltcorr,lldiab
      character*1 cllgrtyp
      integer VFSTLUK,fstecr
      integer jlev,imode,ilev,ji,jj,jk,jpt,indjj
      integer imaxlev
      parameter(imaxlev=200)
      integer itrlgid,iip1s(imaxlev),iip2,iip3
      integer itrlnlev
      integer iig1,iig2,iig3,iig4,ikey
      integer ikind,ibrpstamp
      integer ezgprm
      integer idum1,idum2,idum3,idum4
      integer ip1_pak_trl,ip1_vco_trl
      integer :: k,koutmpg  !  the unit which has the selected records.
!
      real*8 zmin,zmax,zpt,ztstar
      real*8 zeta(nflev)
      real*8 zfld(ni,nj),zwork
      real*8 zonal(nj,nflev)
!
      character*1 cltypinc,clstring
      character*2 cvar(nvar)
!
      integer ifois
      data ifois/0/
      integer fnom,fstouv,fstfrm
      integer jvar,idim,iig1
      integer fstopc,ezqkdef,igdgid,idatyp

!
!!
      write(nulout,*) 'ecr_gu active'
!
      igdgid = ezqkdef(ni, nj, 'G', 0,0,0,0,0)
!
!
      ibrpstamp=nbrpstamp
      ip1 = 0
      ip2 = 0
      ip3 = kniter
      NPAKINC=-16
      cllgrtyp = 'G'
      cltypinc = 'S'
      idatyp=1
!
!     n.b.: 3dvar standard is N to S: we will write S to N and state it with IG2 = 0 RPN standard parameter.
!
      if(knk.eq.1) then
        IP1 =  NIP1(NFLEV)
        do jj=1,nj
          indjj = nj-jj+1
          zonal(jj,1) = pin(1,indjj,1)
          do ji=1,ni
            zfld(ji,jj) = pin(ji,indjj,1)
          enddo
        enddo
        IERR  = VFSTECR(zfld,zwork,NPAKINC,
     &                 kunit,ibrpstamp,0,0,ni,nj,1,
     &                 ip1,ip2,ip3,cltypinc,cdvar,cdetiket,cllgrtyp,
     &                 0,0,0,0,idatyp,.true.)
        IERR  = VFSTECR(zonal,zwork,NPAKINC,
     &                 kunit,ibrpstamp,0,0,1,nj,1,
     &                 ip1,ip2,ip3,cltypinc,cdvar,'SDZONAL ',cllgrtyp,
     &                 0,0,0,0,idatyp,.true.)
      else
        do jlev = 1,knk
          IP1 =  NIP1(jlev)
          do jj=1,nj
            indjj = nj-jj+1
            zonal(jj,jlev) = pin(1,indjj,jlev)
            do ji=1,ni
              zfld(ji,jj) = pin(ji,indjj,jlev)
            enddo
          enddo
          IERR  = VFSTECR(zfld,zwork,NPAKINC,
     &               kunit,ibrpstamp,0,0,ni,nj,1,
     &               ip1,ip2,ip3,cltypinc,cdvar,cdetiket,cllgrtyp,
     &               0,0,0,0,idatyp,.true.)
        enddo
        IERR  = VFSTECR(zonal,zwork,NPAKINC,
     &               kunit,ibrpstamp,0,0,1,nj,knk,
     &               ip1,ip2,ip3,cltypinc,cdvar,'SDZONAL ',cllgrtyp,
     &               0,0,0,0,idatyp,.true.)
      endif
!
      return
      end