!-------------------------------------- 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 sigmaop3d 2,65

#if defined (DOC)
*Author  : Luc Fillion - ARMA/EC - 22 Apr 2009.
*
*Revision:
#endif

      IMPLICIT NONE
#include "comlun.cdk"
#include "comcst.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comgem.cdk"
#include "comgrd_param.cdk"
#include "comgd0.cdk"
#include "compstat.cdk"
#include "comstate.cdk"
#include "comcva.cdk"

      INTEGER JLAT, JLON ,J,ji,jj,jk
      CHARACTER*8 CLETIKET
      CHARACTER*1 CLTYPVAR,CLGRTYP
      CHARACTER*2 CLNOMVAR
      INTEGER IULSSF,IDATEO
      INTEGER VFSTLIR,FSTPRM,FNOM,FSTOUV,FCLOS,FSTFRM
      INTEGER IKEY,ILEN,IERR,IDATE
      integer idum1,idum2,idum3,idum4
!
      real*8 zmin,zmax
      real*8 z2d(ni,nj)
      real*8 z3d(ni,nflev,nj)
      REAL*8 ZBUFFER(ni,nj),ZTRANS(NI,NJ),ZJO

      INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
     +     ,IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
     +     ,IUBC,IEXTR1,IEXTR2,IEXTR3
C----------------------------------------------------------------------
!
      write(nulout,*) 'sigmaop3d: Begin'
!
      if(grd_typ.eq.'LU') then
! UU
        call readgd_lusdev(z3d,'UU',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'UU')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev   ! Wind Images needed here before using newbilin....
          ut0(ji,jk,jj)=z3d(ji,jk,jj)*conima(jj)   ! already in KNTS via readgd_lusdev ...
          if(ut0(ji,jk,jj).le.0.0) then
            write(nulout,*) 'ji,jj,jk,ut0 = ',ji,jj,jk,ut0(ji,jk,jj)
            call abort3d(nulout,'sigmaop3d: negative st-dev for UT0 found...')
          endif
        enddo
        enddo
        enddo
! VV
        call readgd_lusdev(z3d,'VV',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'VV')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          vt0(ji,jk,jj)=z3d(ji,jk,jj)*conima(jj)
          if(vt0(ji,jk,jj).le.0.0) then
            write(nulout,*) 'ji,jj,jk,vt0 = ',ji,jj,jk,vt0(ji,jk,jj)
            call abort3d(nulout,'sigmaop3d: negative st-dev for VT0 found...')
          endif
        enddo
        enddo
        enddo
! GZ
        if(NGEXIST(nggz).eq.1) then
          call readgd_lusdev(z3d,'GZ',nflev)
          call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &                idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &                'GZ')
          do ji=1,ni
          do jj=1,nj
          do jk=1,nflev
            gz0(ji,jk,jj)=z3d(ji,jk,jj)
          enddo
          enddo
          enddo
        endif
! ES
        call readgd_lusdev(z3d,'ES',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'ES')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          q0(ji,jk,jj)=z3d(ji,jk,jj)
          if(q0(ji,jk,jj).le.0.0) then
            write(nulout,*) 'ji,jj,jk,q0 = ',ji,jj,jk,q0(ji,jk,jj)
            call abort3d(nulout,'sigmaop3d: negative st-dev for q0 found...')
          endif
        enddo
        enddo
        enddo
! P0
        call readgd_lusdev(z2d,'P0',1)
        call maxmin(z2d,ni,1,nj,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'P0')
        do ji=1,ni
        do jj=1,nj
          gps0(ji,1,jj)=z2d(ji,jj)
          if(gps0(ji,1,jj).le.0.0) then
            write(nulout,*) 'ji,jj,gps0 = ',ji,jj,jk,gps0(ji,1,jj)
            call abort3d(nulout,'sigmaop3d: negative st-dev for gps0 found...')
          endif
        enddo
        enddo
      else
C
C       1. Opening the statistics file
C
        IULSSF=NULBGST
C
C     .  2.1 Background error standard deviations
C
        CLETIKET = 'STDDEV'
        IDATE    = -1
        IP1      = -1
        IP2      = -1
        IP3      = -1
        CLTYPVAR =' '
        ILEN = (NJEND -NJBEG +1)*NKGDIM
C
C       READ IN STANDARD DEVIATION FOR EACH OBSERVATION TYPE
C
!
!       Set some file parameters
!
        CLNOMVAR = 'UU'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     S       ,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
!
!       Get ig2 to decide if fields are stored from N-->S or S-->N
!
        IERR = FSTPRM(IKEY,IDATEO,IDEET,INPAS
     +     ,INI,INJ,INK, INBITS, IDATYP
     +     ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
     +     ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
     +     ,IUBC,IEXTR1,IEXTR2,IEXTR3)
        write(nulout,*) 'sigmaop3d: ni,nj,inj=',ni,nj,inj
!
!       Reset desired etiket et al. for following reading
!       that has possibly been modified previously by fstprm...
!
        CLETIKET = 'STDDEV'
        IDATE    = -1
        IP2      = -1
        IP3      = -1
        CLTYPVAR =' '
!
        CLNOMVAR = 'UU'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
            IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     S           ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
             DO JLAT = 1, NJ
                DO JLON=1,NI
                   ZTRANS(JLON,JLAT) = ZBUFFER(jlon,jlat)*RMSKNT
                   if(IG2 .eq. 0) then
                    UT0(JLON,J,INJ-JLAT+1) = (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 else
                    UT0(JLON,J,JLAT) =  (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 endif
                END DO
             END DO
        END DO
C
        CLNOMVAR = 'VV'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
             DO JLAT = 1, NJ
                DO JLON=1,NI
                 ZTRANS(JLON,JLAT) = ZBUFFER(jlon,jlat)*RMSKNT
                 if(IG2 .eq. 0) then
                    VT0(JLON,J,INJ-JLAT+1) = (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 else
                    VT0(JLON,J,JLAT) =  (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 endif
                END DO
             END DO
        END DO
        CLNOMVAR = 'ES'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
             DO JLAT = 1, NJ
                DO JLON=1,NI
                 if(IG2 .eq. 0) then
                    Q0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)
                 else
                    Q0(JLON,J,JLAT) = ZBUFFER(jlon,jlat)
                 endif
                 ZTRANS(JLON,JLAT) = ZBUFFER(jlon,jlat)
                END DO
             END DO
        END DO
        CLNOMVAR = 'GZ'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
           DO JLAT = 1, NJ
              DO JLON=1,NI
                 if(IG2 .eq. 0) then
                    TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)*RG*10.
                 else
                    TT0(JLON,J,JLAT) = ZBUFFER(jlon,jlat)*RG*10.
                 endif
                 ZTRANS(JLON,JLAT) = ZBUFFER(jlon,jlat)
              END DO
           END DO
        END DO
      endif
C
C Apply 3D amplification factor
C
      DO JLAT = 1, NJ
        DO J = 1, NFLEV
          DO JLON = 1, NI
            z3d(JLON,J,JLAT) = damplibg(JLON,J,JLAT)       
          enddo
        enddo
      enddo
!
      write(nulout,*) 'sigmaop3d: UU/VV damplibg factor'
      call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &            idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &            'AMP')
!
        DO JLAT = 1, NJ
          DO J = 1, NFLEV
            DO JLON = 1, NI
              UT0(JLON,J,JLAT)= 
     +          UT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)       
              VT0(JLON,J,JLAT)= 
     +          VT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)       
cbue comment out, because tuning is for LQ, not ES
cbue              Q0(JLON,J,JLAT)= 
cbue     +          Q0(JLON,J,JLAT)*damplibg(JLON,J+3*NFLEV,JLAT)       
            END DO
          END DO
        END DO
!
      call newbilin
      CALL TRQTOES
      CALL TRTTOGZ
C
C     SET THE FIRST-GUESS ERRORS FOR CONVENTIONAL DATA ON PRESSURE LEVELS
C     --------------------------------------------------------------------
C
         CALL SETFGEFAM('AI')
         CALL SETFGEFAM('SW')
         CALL SETFGEFAM('UA')
         CALL SETFGEFAM('SF')
         CALL SETFGEFAM('HU')
         CALL SETFGEFAMZ('PR')
C
C     SET THE FIRST-GUESS ERRORS FOR RADIO OCCULTATION DATA
C     -----------------------------------------------------
C
         CALL SETFGEDIF('RO')
C
C     DO TEMPERATURE FIRST-GUESS ERROR
C     ---------------------------------
C
      if(grd_typ.eq.'LU') then
        call readgd_lusdev(z3d,'TT',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'TT')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          tt0(ji,jk,jj)=z3d(ji,jk,jj)
        enddo
        enddo
        enddo
      else
        CLNOMVAR = 'TT'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +       ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
           DO JLAT = 1, NJ
              DO JLON=1,NI
               if(IG2 .eq. 0) then
                  TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)
               else
                  TT0(JLON,J,JLAT) = ZBUFFER(jlon,jlat)
               endif
               ZTRANS(JLON,JLAT) = ZBUFFER(jlon,jlat)
              END DO
           END DO
        END DO
      endif
C
C Apply 3D amplification factor
C
      DO JLAT = 1, NJ
        DO J = 1, NFLEV
          DO JLON = 1, NI
            z3d(JLON,J,JLAT) = damplibg(JLON,J+2*NFLEV,JLAT)       
          enddo
        enddo
      enddo
!
      write(nulout,*) 'sigmaop3d: TT damplibg factor'
      call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &            idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &            'AMP')
!
        DO JLAT = 1, NJ
          DO J = 1, NFLEV
            DO JLON = 1, NI
              TT0(JLON,J,JLAT)= 
     +          TT0(JLON,J,JLAT)*damplibg(JLON,J+2*NFLEV,JLAT)       
            END DO
          END DO
        END DO

      call newbilin
      CALL SETFGETT
C
C
C     DO SATEM FIRST-GUESS ERROR
C     --------------------------
C
      if(grd_typ.eq.'GU'.and.(.not.lcva_hemis)) then  ! left only for global analysis group to update...
        CLNOMVAR = 'DZ'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        write(nulout,*) 'sigmaop3d: SATEM DATA ...'
        write(nulout,*) 'sigmaop3d: WARNING!!!!! this is no more supported here...'
!cluc        call abort3d(nulout,'sigmaop3d: SATEM are obsolete!')
        DO J = 1, INK
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
           DO JLAT = 1, NJ
              DO JLON=1,NI
                 if(IG2 .eq. 0) then
                    TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)*10.
                 else
                    TT0(JLON,J,JLAT) = ZBUFFER(jlon,jlat)*10.
                 endif
                 ZTRANS(JLON,JLAT) = ZBUFFER(jlon,jlat)
              END DO
           END DO
        END DO
        CALL BILIN
        call trttogz
        CALL SETFGEST
      endif
C
C     RELOAD DATA TO DO SURFACE FIRST-GUESS ERRORS
C     ---------------------------------------------
C
      if(grd_typ.eq.'LU') then
! P0
        call readgd_lusdev(z3d,'P0',1)
        call maxmin(z3d,ni,1,nj,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'P0')
        do ji=1,ni
        do jj=1,nj
          gps0(ji,1,jj)=z3d(ji,1,jj)
        enddo
        enddo
! UU
        call readgd_lusdev(z3d,'UU',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'UU')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          ut0(ji,jk,jj)=z3d(ji,jk,jj)*conima(jj)
        enddo
        enddo
        enddo
! VV
        call readgd_lusdev(z3d,'VV',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'VV')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          vt0(ji,jk,jj)=z3d(ji,jk,jj)*conima(jj)
        enddo
        enddo
        enddo
! TT
        call readgd_lusdev(z3d,'TT',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'TT')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          tt0(ji,jk,jj)=z3d(ji,jk,jj)
        enddo
        enddo
        enddo
! ES
        call readgd_lusdev(z3d,'ES',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'ES')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          q0(ji,jk,jj)=z3d(ji,jk,jj)
        enddo
        enddo
        enddo
      else
        CLNOMVAR = 'P0'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,1,IDATE
     &     ,CLETIKET,nip1(nflev),IP2,IP3,CLTYPVAR,CLNOMVAR)
        write(nulout,*) 'sigmaop3d: ini,inj,ni,nj =',ini,inj,ni,nj
        call maxmin(ZBUFFER,ni,1,nj,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'P0 ')
!
        DO JLAT=1,NJ
          DO JLON=1,NI
            if(IG2 .eq. 0) then
              GPS0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)*RMBTPA
            else
              GPS0(JLON,J,JLAT) =       ZBUFFER(jlon,jlat)*RMBTPA
            endif
          END DO
        END DO
!
        CLNOMVAR = 'UU'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
           DO JLAT = 1, NJ
              DO JLON=1,NI
                 if(IG2 .eq. 0) then
                    UT0(JLON,J,INJ-JLAT+1) = (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 else
                    UT0(JLON,J,JLAT) = (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 endif
              END DO
           END DO
        END DO
        CLNOMVAR = 'VV'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
           DO JLAT = 1, NJ
              DO JLON=1,NI
                 if(IG2 .eq. 0) then
                    VT0(JLON,J,INJ-JLAT+1) = (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 else
                    VT0(JLON,J,JLAT) =  (ZBUFFER(jlon,jlat)/CONPHY(JLAT))*RMSKNT
                 endif
              END DO
           END DO
        END DO
        CLNOMVAR = 'TT'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
           DO JLAT = 1, NJ
              DO JLON=1,NI
                 if(IG2 .eq. 0) then
                    TT0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)
                 else
                    TT0(JLON,J,JLAT) = ZBUFFER(jlon,jlat)
                 endif
              END DO
           END DO
        END DO
        CLNOMVAR = 'ES'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +     ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
           DO JLAT = 1, NJ
              DO JLON=1,NI
                 if(IG2 .eq. 0) then
                    Q0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)
                 else
                    Q0(JLON,J,JLAT) = ZBUFFER(jlon,jlat)
                 endif
              END DO
           END DO
        END DO
      endif
C
C Apply 3D amplification factor
C
      DO JLAT = 1, NJ
          DO JLON = 1, NI
            z2d(JLON,JLAT) = damplibg(JLON,1+4*NFLEV,JLAT)       
          enddo
      enddo
!
      write(nulout,*) 'sigmaop3d: damplibg factor'
      call maxmin(z2d,ni,1,nj,zmin,zmax,
     &            idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &            'AMP')
!
        DO JLAT = 1, NJ
          DO JLON = 1, NI
            GPS0(JLON,1,JLAT) =
     +        GPS0(JLON,1,JLAT)*damplibg(JLON,1+4*NFLEV,JLAT)
          END DO
        END DO
        DO JLAT = 1, NJ
          DO J = 1, NFLEV
            DO JLON = 1, NI
              UT0(JLON,J,JLAT)= 
     +          UT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)       
              VT0(JLON,J,JLAT)= 
     +          VT0(JLON,J,JLAT)*damplibg(JLON,J,JLAT)       
              TT0(JLON,J,JLAT)= 
     +          TT0(JLON,J,JLAT)*damplibg(JLON,J+2*NFLEV,JLAT)       
cbue comment out, because tuning is for LQ, not ES
cbue              Q0(JLON,J,JLAT)= 
cbue     +          Q0(JLON,J,JLAT)*damplibg(JLON,J+3*NFLEV,JLAT)       
            END DO
          END DO
        END DO

      call newbilin
C
C     SET THE FIRST-GUESS ERRORS FOR THE SURFACE DATA
C     ------------------------------------------------
C
      CALL SETFGESURF
C
C     READ IN LN Q FIRST-GUESS ERRORS FOR SETFGEGPS
C     ---------------------------------------------
C
      if(grd_typ.eq.'LU') then
! LQ
        call readgd_lusdev(z3d,'LQ',nflev)
        call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &              idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &              'LQ')
        do ji=1,ni
        do jj=1,nj
        do jk=1,nflev
          q0(ji,jk,jj)=z3d(ji,jk,jj)
        enddo
        enddo
        enddo
      else
        CLNOMVAR = 'LQ'
        write(nulout,*) 'sigmaop3d: treating ',CLNOMVAR
        DO J = 1, NFLEV
          IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE
     +       ,CLETIKET,nip1(j),IP2,IP3,CLTYPVAR,CLNOMVAR)
          DO JLAT = 1, NJ
            DO JLON=1,NI
              if(IG2 .eq. 0) then
                 Q0(JLON,J,INJ-JLAT+1) = ZBUFFER(jlon,jlat)
              else
                 Q0(JLON,J,JLAT) = ZBUFFER(jlon,jlat)
              endif
            END DO
          END DO
        END DO
      endif
C
C Apply 3D amplification factor to LQ
C
      DO JLAT = 1, NJ
        DO J = 1, NFLEV
          DO JLON = 1, NI
            z3d(JLON,J,JLAT) = damplibg(JLON,J+3*NFLEV,JLAT)       
          enddo
        enddo
      enddo
!
      write(nulout,*) 'sigmaop3d: LQ damplibg factor'
      call maxmin(z3d,ni,nj,nflev,zmin,zmax,
     &            idum1,idum2,idum3,idum4,'sigmaop3d      ',
     &            'AMP')
!
      DO JLAT = 1, NJ
         DO J = 1, NFLEV
            DO JLON = 1, NI
               Q0(JLON,J,JLAT)=
     +           Q0(JLON,J,JLAT)*damplibg(JLON,J+3*NFLEV,JLAT)
            END DO
         END DO
      END DO

      CALL NEWBILIN
C
C     SET THE FIRST-GUESS ERRORS FOR GB-GPS ZTD DATA
C     ------------------------------------------------
C
      CALL SETFGEGPS
C
      RETURN
      END