!--------------------------------------- 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 SIGMAOP_NEWFMT(lcolumng,lcolumnhr,lobsSpaceData) 1,76

!*Author  : P. Koklas CMDA/SMC
!*
      use EarthConstants_mod
      use MathPhysConstants_mod
      use obsSpaceData_mod
      use columnData_mod
      use gridStateVector_mod
      use HorizontalCoord_mod
      IMPLICIT NONE

      type(struct_hco), pointer        :: hco_anl
      type(struct_vco), pointer        :: vco_anl
      type(struct_obs)        :: lobsSpaceData
      type(struct_columnData) :: lcolumn,lcolumng,lcolumnhr
      type(struct_gsv)        :: statevector

      INTEGER JLAT, JLON, J, JOBS

      CHARACTER*12 CLETIKET
      CHARACTER*2 CLTYPVAR
      CHARACTER*1 CLGRTYP
      CHARACTER*4 CLNOMVAR

      INTEGER IULSSF,IDATEO
      INTEGER VFSTLIR,FSTPRM,FNOM,FSTOUV,FCLOS,FSTFRM
      INTEGER IKEY,ILEN,IERR,IDATE

      REAL*8, allocatable :: ZBUFFER(:)
      real*8, pointer     :: gz_column(:), tt_column(:), field_ptr(:,:,:)

      INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
      INTEGER IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
      INTEGER IUBC,IEXTR1,IEXTR2,IEXTR3

      !- Get the appropriate Horizontal and Vertical Coordinate
      hco_anl => hco_Get('Analysis')
      vco_anl => col_getVco(lcolumng)

      allocate(ZBUFFER(HCO_ANL % NJ))

      call gsv_setVco(statevector,col_getVco(lcolumng))
      call gsv_setHco(statevector,hco_anl)
      call gsv_allocate(statevector,1)
      call gsv_zero(statevector)

      call col_setVco(lcolumn,col_getVco(lcolumng))
      call col_allocate(lcolumn,col_getNumCol(lcolumng))
      call col_copyLatLon(lcolumng,lcolumn)
!C
!C     1. Opening the statistics file
!C
      IULSSF=0
      IERR=FNOM(iulssf,'./bgcov','RND+OLD+R/O',0)
      IF ( IERR .EQ. 0 ) THEN
        write(*,*) 'IBGST - File : ./bgcov'
        write(*,*) ' opened as unit file ',iulssf
        ierr =  fstouv(iulssf,'RND+OLD')
      ELSE
        CALL ABORT3D('SIGMAOP_NEWFMT:NO BACKGROUND STAT FILE!!')
      ENDIF
!C
!C     .  2.1 Background error standard deviations
!C
      CLETIKET = 'STDDEV'
      write(*,*) 'sigmaop_newfmt: CLETIKET = ',CLETIKET
      IDATE    = -1
      IP2      = -1
      IP3      = -1
      CLTYPVAR =' '
!C
!C READ IN STANDARD DEVIATION FOR EACH OBSERVATION TYPE
!C
      CLNOMVAR = 'UU'
      write(*,*) CLNOMVAR 
      field_ptr => gsv_getField3D(statevector,'UU')       
      do j = 1,col_getNumLev(LCOLUMNG,'MM')
         IP1 = vco_anl%ip1_M(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         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)
         if (ini /= 1 .or. inj /= hco_anl % nj .or. ink /= 1) then
            write(*,*)
            write(*,*) 'sigmaop_newfmt: Invalid dimensions for...'
            write(*,*) 'nomvar         =', trim(CLNOMVAR)
            write(*,*) 'etiket         =', trim(CLETIKET)
            write(*,*) 'Found ni,nj,nk =', ini, inj, ink
            write(*,*) 'Should be      =', 1, hco_anl % nj, col_getNumLev(LCOLUMNG,'MM')
            stop
         end if
         DO JLAT = 1, hco_anl % nJ
            DO JLON=1,hco_anl % nI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               endif
             END DO
          END DO
      END DO

      CLNOMVAR = 'VV'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'VV')
      do j = 1,col_getNumLev(LCOLUMNG,'MM')
         IP1 = vco_anl%ip1_M(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         if (ini /= 1 .or. inj /= hco_anl % nj .or. ink /= 1) then
            write(*,*)
            write(*,*) 'sigmaop_newfmt: Invalid dimensions for...'
            write(*,*) 'nomvar         =', trim(CLNOMVAR)
            write(*,*) 'etiket         =', trim(CLETIKET)
            write(*,*) 'Found ni,nj,nk =', ini, inj, ink
            write(*,*) 'Should be      =', 1, hco_anl % nj, col_getNumLev(LCOLUMNG,'MM')
            stop
         end if

         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               endif
            END DO
         END DO
      END DO

      CLNOMVAR = 'ES'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'HU')
      DO J = 1, col_getNumLev(LCOLUMNG,'TH')
         IP1 = vco_anl%ip1_T(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         if (ini /= 1 .or. inj /= hco_anl % nj .or. ink /= 1) then
            write(*,*)
            write(*,*) 'sigmaop_newfmt: Invalid dimensions for...'
            write(*,*) 'nomvar         =', trim(CLNOMVAR)
            write(*,*) 'etiket         =', trim(CLETIKET)
            write(*,*) 'Found ni,nj,nk =', ini, inj, ink
            write(*,*) 'Should be      =', 1, hco_anl % nj, col_getNumLev(LCOLUMNG,'TH')
            stop
         end if
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)
               endif
            END DO
         END DO
      END DO

      ! GZ is put into TT slot in gridStateVector
      CLNOMVAR = 'GZ'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'TT')
      DO J = 1, col_getNumLev(LCOLUMNG,'TH')
         IP1 = vco_anl%ip1_T(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         if (ini /= 1 .or. inj /= hco_anl % nj .or. ink /= 1) then
            write(*,*)
            write(*,*) 'sigmaop_newfmt: Invalid dimensions for...'
            write(*,*) 'nomvar         =', trim(CLNOMVAR)
            write(*,*) 'etiket         =', trim(CLETIKET)
            write(*,*) 'Found ni,nj,nk =', ini, inj, ink
            write(*,*) 'Should be      =', 1, hco_anl % nj, col_getNumLev(LCOLUMNG,'TH')
            stop
         end if
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)*RG*10.d0
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)*RG*10.d0
               endif
            END DO
         END DO
      END DO

      CALL BILIN(lcolumn,statevector,lobsSpaceData)

      ! copy GZ data from TT to GZ slot in columnData
      do jobs= 1, col_getNumCol(lcolumn)
         gz_column => col_getColumn(lcolumn,jobs,'GZ','TH')
         tt_column => col_getColumn(lcolumn,jobs,'TT')
         do j = 1,col_getNumLev(lcolumn,'TH')
            gz_column(j)=tt_column(j)
         enddo
      enddo

!C
!C    SET THE FIRST-GUESS ERRORS FOR CONVENTIONAL DATA ON PRESSURE LEVELS
!C    --------------------------------------------------------------------
!C
      CALL SETFGEFAM('AI',lcolumn,lcolumng,lobsSpaceData)
      CALL SETFGEFAM('SW',lcolumn,lcolumng,lobsSpaceData)
      CALL SETFGEFAM('UA',lcolumn,lcolumng,lobsSpaceData)
      CALL SETFGEFAM('SF',lcolumn,lcolumng,lobsSpaceData)
      CALL SETFGEFAM('HU',lcolumn,lcolumng,lobsSpaceData)
      CALL SETFGEFAMZ('PR',lcolumn,lcolumng,lobsSpaceData)
!C
!C    SET THE FIRST-GUESS ERRORS FOR RADIO OCCULTATION DATA
!C    -----------------------------------------------------
!C
      CALL SETFGEDIF('RO',lcolumng,lobsSpaceData)

!C
!C    DO TEMPERATURE FIRST-GUESS ERROR
!C    ---------------------------------
!C
      CLNOMVAR = 'TT'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'TT')
      DO J = 1, col_getNumLev(LCOLUMNG,'TH')
         IP1 = vco_anl%ip1_T(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         if (ini /= 1 .or. inj /= hco_anl % nj .or. ink /= 1) then
            write(*,*)
            write(*,*) 'sigmaop_newfmt: Invalid dimensions for...'
            write(*,*) 'nomvar         =', trim(CLNOMVAR)
            write(*,*) 'etiket         =', trim(CLETIKET)
            write(*,*) 'Found ni,nj,nk =', ini, inj, ink
            write(*,*) 'Should be      =', 1, hco_anl % nj, col_getNumLev(LCOLUMNG,'TH')
            stop
         end if
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)
               endif
            END DO
         END DO
      END DO

      CALL BILIN(lcolumn,statevector,lobsSpaceData)
      CALL SETFGETT(lcolumn,lcolumng,lobsSpaceData)

!C
!C     RELOAD DATA TO DO SURFACE FIRST-GUESS ERRORS
!C     ---------------------------------------------
!C
      CLNOMVAR = 'P0'
      write(*,*) CLNOMVAR
      IP1 = -1
      IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
      if (ini /= 1 .or. inj /= hco_anl % nj .or. ink /= 1) then
         write(*,*)
         write(*,*) 'sigmaop_newfmt: Invalid dimensions for...'
         write(*,*) 'nomvar         =', trim(CLNOMVAR)
         write(*,*) 'etiket         =', trim(CLETIKET)
         write(*,*) 'Found ni,nj,nk =', ini, inj, ink
         write(*,*) 'Should be      =', 1, hco_anl % nj, 1
         stop
      end if
      field_ptr => gsv_getField3D(statevector,'P0')
      DO J = 1, INK
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)*MPC_PA_PER_MBAR_R8
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)*MPC_PA_PER_MBAR_R8
               endif
            END DO
         END DO
      END DO

      CLNOMVAR = 'UU'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'UU')
      DO J = 1, col_getNumLev(LCOLUMNG,'MM')
         IP1 = vco_anl%ip1_M(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               endif
            END DO
         END DO
      END DO

      CLNOMVAR = 'VV'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'VV')
      DO J = 1, col_getNumLev(LCOLUMNG,'MM')
         IP1 = vco_anl%ip1_M(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)*MPC_M_PER_S_PER_KNOT_R8
               endif
            END DO
         END DO
      END DO

      CLNOMVAR = 'TT'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'TT')
      DO J = 1, col_getNumLev(LCOLUMNG,'TH')
         IP1 = vco_anl%ip1_T(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)
               endif
            END DO
         END DO
      END DO

      CLNOMVAR = 'ES'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'HU')
      DO J = 1, col_getNumLev(LCOLUMNG,'TH')
         IP1 = vco_anl%ip1_T(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                  field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)
               else
                  field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)
               endif
            END DO
         END DO
      END DO

      CALL BILIN(lcolumn,statevector,lobsSpaceData)
!C
!C    SET THE FIRST-GUESS ERRORS FOR THE SURFACE DATA
!C    ------------------------------------------------
!C
      CALL SETFGESURF(lcolumn,lcolumng,lobsSpaceData)

!C    READ IN LN Q FIRST-GUESS ERRORS FOR SETFGEGPS
!C    ---------------------------------------------
!C
      CLNOMVAR = 'LQ'
      write(*,*) CLNOMVAR
      field_ptr => gsv_getField3D(statevector,'HU')
      DO J = 1, col_getNumLev(LCOLUMNG,'TH')
         IP1 = vco_anl%ip1_T(j)
         IKEY = VFSTLIR(ZBUFFER,IULSSF,INI,INJ,INK,IDATE,CLETIKET,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR)
         if (ini /= 1 .or. inj /= hco_anl % nj .or. ink /= 1) then
            write(*,*)
            write(*,*) 'sigmaop_newfmt: Invalid dimensions for...'
            write(*,*) 'nomvar         =', trim(CLNOMVAR)
            write(*,*) 'etiket         =', trim(CLETIKET)
            write(*,*) 'Found ni,nj,nk =', ini, inj, ink
            write(*,*) 'Should be      =', 1, hco_anl % nj, col_getNumLev(LCOLUMNG,'TH')
            stop
         end if
         DO JLAT = 1, HCO_ANL % NJ
            DO JLON=1,HCO_ANL % NI
               if(IG2 .eq. 0) then
                   field_ptr(JLON,J,INJ-JLAT+1) = ZBUFFER(JLAT)
               else
                   field_ptr(JLON,J,JLAT) =       ZBUFFER(JLAT)
               endif
            END DO
         END DO
      END DO

      CALL BILIN(lcolumn,statevector,lobsSpaceData)
!C
!C    SET THE FIRST-GUESS ERRORS FOR GB-GPS ZTD DATA
!C    ------------------------------------------------
!C
      CALL SETFGEGPS(lcolumn,lcolumng,lobsSpaceData)

      call col_deallocate(lcolumn)
      deallocate(ZBUFFER)

      RETURN
      END SUBROUTINE SIGMAOP_NEWFMT