 MODULE GAC_1B_PROC

      implicit none

!     Include machine dependent parameters.
      include 'gac1b.inc'                  ! Header and data record definition
      include 'rfac.inc'                   ! Record length divisor

!     Declare/set parameters.
!      avh_mxpix = total number of bytes (4608) in AVHRR GAC data record
!      cavh_size = number of 4-byte words in avh_mxpix bytes (4608/4=1152)
!      nid,nnd= number of arguments in arrays in DATTIM call.
!      mch    = number of channels
!      mpos   = number of spots (positions) on a scan line
!
 integer, parameter :: real_32=selected_real_kind(6,37)
 integer, parameter :: real_64=selected_real_kind(15,307)
 integer, parameter :: mch=5,mpos=409,maxread=200000
 integer, parameter :: nreal=22,ntot=nreal+mch,bit_qc=0
 integer, parameter :: stdout=6,lu1b=11,wbf_sea_a_lcr=51,wbf_lnd_o_cld=52
 integer, parameter :: lundx=20,nprint=500,nmon=12
 integer, parameter :: nlat_msk=2881,nlon_msk=5761,nlat_sst=360,nlon_sst=720

 real, parameter :: lon1_msk=-180.0,lat1_msk=90.0,lon2_msk=180.0,lat2_msk=-90.0
 real, parameter :: lon1_sst=0.25,lat1_sst=-89.75,lon2_sst=359.75,lat2_sst=89.75
 real, parameter :: tlo=100.,thi=400.,vislo=0.01,vishi=100.
 real, parameter :: dxy=0.5,dtr=3.141593,ttp=271.5
 real(8), parameter :: bmiss=10e8_8

! Variables
!
 integer :: lsubdrp,ierr,lapchrp,ltnkidp,ltnkid,lsubdr,lapchr,kdate,jdate
 integer :: cld_bit,clavr_cld,id_ncep,itime
 integer :: pyear0,pddd0,pyear,pddd,yyyy,mm,dd,hh,atime,nbf,ilat,ilon,iret
 integer :: idate,rtgsst,navysst,iline,iyear,iddd,jyd,jtype,j3ab,nrecs,nscan
 integer :: nri,nrec,jmd1,jmd2,jmd3,sathgt,jsat,jsat0,nlo,line,ioff,i,j,k,n,ios
 integer :: imon,jmon,im,idum,nlev,flag,missing,lu_ncepsst,iy_ncep,im_ncep
!DAK
 integer :: ilimb
!DAK

 integer*1 :: land_sea_tag

 real(real_64) scale,scale5,scale6,scale7,scale9,scale12,sctime

 logical :: ex,lfirst

 character(len=80) :: APPCHR,APPCHRP
 character(len=12) :: SUBDIR,TANKID,SUBDIRP,TANKIDP
 character(len=10) :: catime
 character(len=8) :: cncepsst_date,statid,cid,TLFLAG,TLFLAGP,SUBSET,SUBSETP
 character(len=4) :: cyyyy
 character(len=2) :: cmm,cdd,chh

! Arrays
!
 integer, dimension(mch,mpos) :: counts
 integer, dimension(mch) :: ichan
 integer, dimension(6) :: good_lines,bad_lines
 integer, dimension(-1:10), public :: lu_bufr
 integer, dimension(mpos) :: cld
 integer, dimension(-1:0) :: pyyyyddd,pyyyy,pyy,pmm,pdd
 integer, dimension(-1:0) :: sst_date,lu_sst

 integer idt(3),ndt(7),intime(8),outime(8)

 integer*1, dimension(nlon_msk,nlat_msk) :: lst

 real, dimension(nmon,nlat_sst,nlon_sst) :: clima
 real, dimension(mpos) :: solzen,satzen,rlocaz,alat,alon,avh_qc
 real, dimension(mch,mpos) :: avh_rad,avh_bt

 real(8), dimension(ntot) :: rdata

 real    rinc(5)

 character(len=2), dimension(-1:100), public :: cpmm,cpdd
 character(len=2), dimension(6) :: chn_name
 character(len=4), dimension(-1:100), public :: cpyyyy
 character(len=10),dimension(20) :: cbufr_time

 real(8) :: time_min, time_max, r_time
 logical :: do_bufrize

! Data assignment
!
 data chn_name/'01','02','3B','04','05','3A'/
 data good_lines/6*0/
 data  bad_lines/6*0/
 data ichan / 1, 2, 3, 4, 5/
 data nrec/0/
 data lfirst /.false./

contains

      SUBROUTINE AVHRR(SUBSET,SUBSETP)
!$$$  subprogram documentation block
!
! SUBPROGRAM:    AVHRR
!   PRGMMR: KEYSER           ORG: NP22        DATE: 2006-10-19
!
! ABSTRACT: Decodes a single scan line from a raw AVHRR 1B format file and
!    stores report (selected spot) observations into array for later encoding
!    into output BUFR file.
!
! PROGRAM HISTORY LOG:
! 2003-01-29  Xu Li   Original author
! 2006-10-19  Keyser  Improved docblocks and comments
!
! USAGE:    CALL AVHRR(SUBSET,SUBSETP)
!   INPUT ARGUMENT LIST:
!     SUBSET  - BUFR message type for clear and oceanic reports
!     SUBSETP - BUFR message type for cloudy or overland reports
!
! REMARKS: None
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90 (free format)
!   MACHINE:  NCEP WCOSS
!
!$$$

      implicit none

      character(len=8) :: SUBSET,SUBSETP

!  Extract scan line number, date/time, position, and type
!  -------------------------------------------------------

      iline  = avh_scnlin                  ! scan line number
      iyear  = avh_scnlinyr                ! scan line year
      iddd   = avh_scnlindy                ! scan line day of year
      itime  = avh_scnlintime              ! scan line UTC time of day in
                                           !  milliseconds
      sctime = 1.d-3*itime
      jyd    = 1000*iyear + iddd

!  Get year  : ndt(1)
!     month  : ndt(2)
!     day    : ndt(3)
!     hour   : ndt(4)
!     minute : ndt(5)
!     second : ndt(6)
!     milisecond : ndt(7)
!
!!!!! call dattim(idt,ndt)

      im = ndt(2)

!  Determine the selection mode for Channel 3 (A or B)
!  ---------------------------------------------------

      j3ab = ibits(avh_scnlinbit,0,1)      ! 0 = 3B; 1 = 3A

!  Extract navigation data
!  -----------------------

      scale  = 1.d-1
      sathgt = avh_scalti*scale            ! spacecraft altitude (km)

!  Extract earth location data
!  ---------------------------

      scale = 1.d-4
      do i = 5,mpos,8
         alat(i) =  avh_pos(1,(i-5)/8+1)*scale
         alon(i) =  avh_pos(2,(i-5)/8+1)*scale
      end do

!  Extract angular relationships
!  -----------------------------

      scale = 1.d-2
      do i = 5,mpos,8
         solzen(i)  = avh_ang(1,(i-5)/8+1)*scale
         satzen(i)  = avh_ang(2,(i-5)/8+1)*scale
         rlocaz(i)  = avh_ang(3,(i-5)/8+1)*scale
      end do

!  Angles and lat/lon are only available for 51 pixels in one AVHRR GAC scan
!   line (mpos pixels), interpolation is needed to get the lat/lon for every
!   pixel
!  -------------------------------------------------------------------------

      call lag(solzen,0)
      call lag(satzen,0)
      call lag(rlocaz,0)

      call lag(alat,0)
      call lag(alon,1)

!  Extract AVHRR counts
!  --------------------

      ioff = -4
      do i = 1, 408, 3
         ioff = ioff + 5

!  Unpack channel 1
!  ----------------

         counts(1,i+0) = ibits(avh_hrpt(ioff+0),20,10)
         counts(1,i+1) = ibits(avh_hrpt(ioff+1), 0,10)
         counts(1,i+2) = ibits(avh_hrpt(ioff+3),10,10)

!  Unpack channel 2
!  ----------------

         counts(2,i+0) = ibits(avh_hrpt(ioff+0),10,10)
         counts(2,i+1) = ibits(avh_hrpt(ioff+2),20,10)
         counts(2,i+2) = ibits(avh_hrpt(ioff+3), 0,10)

!  Unpack channel 3 (A or B)
!  -------------------------

         counts(3,i+0) = ibits(avh_hrpt(ioff+0), 0,10)
         counts(3,i+1) = ibits(avh_hrpt(ioff+2),10,10)
         counts(3,i+2) = ibits(avh_hrpt(ioff+4),20,10)

!  Unpack channel 4
!  ----------------

         counts(4,i+0) = ibits(avh_hrpt(ioff+1),20,10)
         counts(4,i+1) = ibits(avh_hrpt(ioff+2), 0,10)
         counts(4,i+2) = ibits(avh_hrpt(ioff+4),10,10)

!  Unpack channel 5
!  ----------------

         counts(5,i+0) = ibits(avh_hrpt(ioff+1),10,10)
         counts(5,i+1) = ibits(avh_hrpt(ioff+3),20,10)
         counts(5,i+2) = ibits(avh_hrpt(ioff+4), 0,10)

      enddo

      ioff = ioff + 5                      ! ioff = 681

      counts(1,mpos) = ibits(avh_hrpt(ioff+0),20,10)
      counts(2,mpos) = ibits(avh_hrpt(ioff+0),10,10)
      counts(3,mpos) = ibits(avh_hrpt(ioff+0), 0,10)
      counts(4,mpos) = ibits(avh_hrpt(ioff+1),20,10)
      counts(5,mpos) = ibits(avh_hrpt(ioff+1),10,10)

! (1) Convert counts into radiances and albedo/Tb
!     (may contain missing values: bad calibration ...);
! (2) Save the quality indicator for each pixel : avh_qc(i),i = 1, mpos
! (3) Save the statistics of the number of good/bad lines:
!      good_lines(i) and bad_lines(i), i = 1, 6
!  --------------------------------------------------------------------

      call gac_lbc(iline)

!  Decode CLAVR cloud detection information (flags)
!  ------------------------------------------------

      cld = 7                              ! 7 = missing
      cld_bit = ibits(clv_bit,0,1)

      if ( cld_bit == 1 ) then
         do i = 1, 401, 8
            n = (i-1)/8 + 1                ! 1 2 3 4 ... 50 51
            do j = 0, 7
                                ! i + j = 1 2 ... 8 9 10 ... 16 ... 401 ... 408
               cld(i+j) = ibits(ccmc(n),14-2*j,2)
            enddo
         enddo
         cld(mpos) = ibits(ccmc(52),14,2)
      endif

!  Exclude the pixels overland and definitely cloudy
!  -------------------------------------------------

      do i = 1,mpos

         if (avh_qc(i) == 0.0) then
            ilat = nint((nlat_msk-1)*(alat(i)-lat1_msk)/(lat2_msk-lat1_msk)) + 1
            ilon = nint((nlon_msk-1)*(alon(i)-lon1_msk)/(lon2_msk-lon1_msk)) + 1
            ilat = max(1,min(ilat,nlat_msk))
            ilon = max(1,min(ilon,nlon_msk))
            land_sea_tag = lst(ilon,ilat)

            if ( land_sea_tag == 1 ) then
               avh_qc(i) = 2.0             ! exclude overland pixels
            elseif ( land_sea_tag == 0 ) then
               if ( cld(i) == 3 .or. cld(i) == 2 ) then
                  clavr_cld = clavr_cld + 1
                  avh_qc(i) = 2.0          ! cloudy
               endif
            endif
         endif
      enddo

!  Write AVHRR data for each spot position on current scan line
!  ------------------------------------------------------------

      do i = 1,mpos

!DAK
!  Temporary fix by DAK to exclude any "spots" on the limb of the scans
!   because the extrapolations may not be done properly in subroutine LAG
!   (e.g., longitude which can vary greatly from one reported spot to the
!   next at very high latitudes) - Xu Li is working on a permanent fix
!  ----------------------------------------------------------------------
         if(i.lt.5.or.i.gt.(mpos-4))  then
            ilimb = ilimb + 1
!ppppppp
!!!!!       print *, 'On scan ',iline,'; toss this spot - on limb, pos = ',i
!ppppppp
            cycle
         endif
!DAK

         if (avh_qc(i) == 0.0 .or. avh_qc(i) == 2.0) then

            idt(1) = itime/1000
            idt(2) = mod(jyd,1000)
            idt(3) = jyd/1000

            call dattim(idt,ndt)
            intime(1:3) = ndt(1:3)
            intime(4) = 0
            intime(5:7) = ndt(4:6)
            intime(8) = mod(itime,1000)

            rinc(1:4) = 0.0
            rinc(5) = real(500000 + 125*i) / 1000.
            call w3movdat(rinc,intime,outime)

!  Assign array for BUFR
!  ---------------------

            rdata( 1) = outime(1)          ! 4-digit year
            rdata( 2) = outime(2)          ! month of a year
            rdata( 3) = outime(3)          ! day of a month
            rdata( 4) = outime(5)          ! hour of a day
            rdata( 5) = outime(6)          ! minute of a hour
                                           ! second of a minute (high-res)
            rdata( 6) = 1.0_8 * outime(7) + 0.001_8 * &
                        (real(outime(8)) + rinc(5) - int(rinc(5)))

!!!!!       print *,'nrec, rdata( 6) : ',nrec, rdata(6)

            rdata( 7) = alat(i)            ! latitude
            rdata( 8) = alon(i)            ! longitude
            rdata( 9) = jsat               ! Satellite ID
            rdata(10) = jtype              ! Instrument ID (2 = AVHRR)
            rdata(11) = iline              ! Number of scan line
            rdata(12) = i                  ! Number of the field of view
            rdata(13) = sathgt*1000        ! Satellite altitude
            rdata(14) = satzen(i)          ! satellite zenith angle
            rdata(15) = solzen(i)          ! solar zenith angle
            rdata(16) = j3ab               ! Mode of 3A/3B: 0 = 3B, 1 = 3A
            rdata(17) = cld(i)             ! CLAVR cloud flag:
                                           !    0 = clear,
                                           !    1 = probably clear,
                                           !    2 = probably cloudy,
                                           !    3 = cloudy
            rdata(18) = avh_bt(1,i)        ! AVHRR (GAC) for Ch-1 albedo
            rdata(19) = avh_bt(2,i)        ! AVHRR (GAC) for Ch-2 albedo
            rdata(20) = avh_bt(3,i)        ! AVHRR (GAC) for Ch-3 alb/Tb
            rdata(21) = avh_bt(4,i)        ! AVHRR (GAC) for Ch-4 Tb
            rdata(22) = avh_bt(5,i)        ! AVHRR (GAC) for Ch-5 Tb

            nrec = nrec + 1

!!!!!       write(*,'(2I8,5f16.2)') clavr_cld,cld(i),avh_bt(1,i),avh_bt(2,i), &
!!!!!                               avh_bt(3,i),avh_bt(4,i),avh_bt(5,i)

            do_bufrize = .false.
            r_time =(rdata(1)*1E8+rdata(2)*1E6+rdata(3)*1E4+rdata(4)*1E2+rdata(5))*1E2&
                +rdata(6)
            if (r_time .gt. time_min .and. r_time .le. time_max) then
               do_bufrize = .true.
            endif

            if (do_bufrize) call bufr1b(avh_qc(i),subset,subsetp)     ! Encode data in BUFR

         endif
      end do

      END SUBROUTINE AVHRR

      SUBROUTINE BUFR1B(MQC,SUBSET,SUBSETP)
!$$$  MAIN PROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM: BUFR1B
!   PRGMMR: KEYSER           ORG: NP22        DATE: 2006-10-19
!
! ABSTRACT: Generates a single BUFR subset (report) from AVHRR GAC 1B data on
!   a single "spot" (on a scan line) and encodes it into output BUFR file.
!
! PROGRAM HISTORY LOG:
! 2003-01-29  Xu Li   Original author
! 2006-10-19  Keyser  Improved docblocks and comments
! 2015-09-09  Stokes  Minor corrections, including those to preserve precision
!                     when handling real*8 data
! 2016-04-15  Stokes  Force a call to openmb before data values are added to a new
!                     bufr subset for output. This ensures the subset is written
!                     to a bufr message with an appropriate section 1 date.
!
! USAGE: CALL BUFR1B(MQC,SUBSET,SUBSETP)
!
!   INPUT ARGUMENTS:
!     MQC     - Real indicator for either clear and oceanic (=0.0) or cloudy or
!               overland (=2.0)
!     SUBSET  - BUFR message type for clear and oceanic reports
!     SUBSETP - BUFR message type for cloudy or overland reports
!
! REMARKS: None
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90 (free format)
!   MACHINE:  NCEP WCOSS
!
!$$$

      CHARACTER*80  HEADR
      CHARACTER*8   SUBSET,SUBSETP, SUBSETO
      REAL(8)       INCN(5), TMBR(5), ALBD(5)
      REAL(8)       HDR(13),BUFRF(3,5)
      real :: mqc

      DATA  HEADR/&
         'YEAR MNTH DAYS HOUR MINU SECO CLATH CLONH SAID FOVN SAZA SOZA CLAVR'/

!  TRANSLATE ONE AVHRR(GAC) SPOT TO BUFR FORMAT
!  ----------------------------------------------------------
!  NC021xxx | YEAR     MNTH     DAYS     HOUR     MINU
!  NC021xxx ! 202129 201132 SECO 201000 202000
!  NC021xxx | CLATH    CLONH    SAID     201129 FOVN 201000
!  NC021xxx | SAZA     SOZA     CLAVR "AVCSEQ"5
!           |
!   AVCSEQ  | INCN    ALBD    TMBR
!  -----------------------------------------------------------

      ALBD = bmiss
      TMBR = bmiss

      if ( rdata(16) == 0. ) then          ! 3B

         ALBD(1) = rdata(18)               ! Ch-1 albedo
         ALBD(2) = rdata(19)               ! Ch-2 albedo
         TMBR(3) = rdata(20)               ! Ch-3 BT
         TMBR(4) = rdata(21)               ! Ch-4 BT
         TMBR(5) = rdata(22)               ! Ch-5 BT

      elseif ( rdata(16) == 1. ) then      ! 3A

         ALBD(1) = rdata(18)               ! Ch-1 albedo
         ALBD(2) = rdata(19)               ! Ch-2 albedo
         ALBD(3) = rdata(20)               ! Ch-3 albedo
         TMBR(4) = rdata(21)               ! Ch-4 BT
         TMBR(5) = rdata(22)               ! Ch-5 BT

      endif

      HDR( 1) = rdata( 1)                  ! 4-digit year
      HDR( 2) = rdata( 2)                  ! month of a year
      HDR( 3) = rdata( 3)                  ! day of a month
      HDR( 4) = rdata( 4)                  ! hour of a day
      HDR( 5) = rdata( 5)                  ! minute of a hour
      HDR( 6) = rdata( 6)                  ! second of a minute
      HDR( 7) = rdata( 7)                  ! latitude
      HDR( 8) = rdata( 8)                  ! longitude
      HDR( 9) = rdata( 9)                  ! Satellite ID
      HDR(10) = rdata(12)                  ! IFOV
      HDR(11) = rdata(14)                  ! satellite zenith angle
      HDR(12) = rdata(15)                  ! solar zenith angle
      HDR(13) = rdata(17)                  ! CLAVR cloud flag

      DO N=1,5
         BUFRF(1,N) = N + 47
         BUFRF(2,N) = ALBD(N)
         BUFRF(3,N) = TMBR(N)
      ENDDO

      idate = &
  idnint(rdata(1))*1000000+idnint(rdata(2))*10000+idnint(rdata(3))*100+idnint(rdata(4))

      if (mqc == 0.0 ) then               ! Clear and oceanic reports
         if ( nbf /= wbf_sea_a_lcr ) then
            CALL CLOSMG(wbf_lnd_o_cld)
            nbf = wbf_sea_a_lcr
            SUBSETO=SUBSET
         endif
!               write(99,"(I5,',',4(I3,','),5(f10.4,','),I3)") &
!               int(rdata(1)),int(rdata(2)),int(rdata(3)),int(rdata(4)),int(rdata(5)),&
!               rdata( 8), rdata( 7), rdata(20), rdata(21),rdata(22),int(rdata(17))
      elseif (mqc == 2.0 ) then           ! Cloudy or overland reports
         if ( nbf /= wbf_lnd_o_cld ) then
            CALL CLOSMG(wbf_sea_a_lcr)
            nbf = wbf_lnd_o_cld
            SUBSETO=SUBSETP
         endif
      else
            write(*,*)'***'
            write(*,*)'*** Exit 7: Unexpected value for mqc: ',mqc,' ***'
            write(*,*)'***'
            call errexit(7)
      endif

      CALL OPENMB(nbf,SUBSETO,idate)
      CALL UFBINT(nbf,HDR,  13,1,IRET,HEADR)
      CALL UFBREP(nbf,BUFRF, 3,5,IRET,'INCN ALBD TMBR')
      CALL WRITCP(nbf)                   ! Write subset (report) into
                                         !  compressed BUFR message

      END SUBROUTINE BUFR1B

      SUBROUTINE GAC_LBC(LINE)
!$$$  MAIN PROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM: GAC_LBC
!   PRGMMR: KEYSER           ORG: NP22        DATE: 2006-10-19
!
! ABSTRACT: For each Level 1B AVHRR scan line, converts numerical counts into
!   radiances and brightness temperatures (GAC Level 1C).
!
! PROGRAM HISTORY LOG:
! 2003-01-14  Xu Li   Original author
! 2006-10-19  Keyser  Improved docblocks and comments
!
! USAGE: CALL GAC_LBC(LINE)
!
!   INPUT ARGUMENTS:
!     LINE   - Scan line number
!
! REMARKS:
!       Needs include files "gac1b.inc" and "cavh_cpi.inc"
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90 (free format)
!   MACHINE:  NCEP WCOSS
!
!$$$

      implicit none

!---- DECLARATIONS -----------------------------------------------------

      character*62 sccid
      data sccid/'%Z% %M% version %I% on %G%'/

!---- ARGUMENTS --------------------------------------------------------

      integer line		           ! Scan line number

      include 'gac1b.inc'                  ! Header and data record definition
      include 'cavh_cpi.inc'               ! AVHRC1 "CPIDS" related parameters

!---- LOCAL VARIABLES --------------------------------------------------

      integer p,c		           ! Pixel, channel
      real rcount		           ! Earth viewed numerical count
      integer ncount		           ! Earth viewed numerical count

      real slope		           ! Coeff. for visible calibration
      real intercept		           ! ....
      real tabalb(0:1023,3)	           ! Table for count to albedo

      real k1,k2,k3		           ! Coeff. conversion count ->radiance
      double precision nu	           ! Central wavenumber
      real radiance		           ! Radiance  mW/cm2.st.cm-1
      integer expon3                       ! Exponent of scaling factor for 1st
                                           !  IR cal. coeff
      integer expon4                       ! Exponent of scaling factor for 2nd
                                           !  IR cal. coeff
      integer expon5                       ! Exponent of scaling factor for 3rd
                                           !  IR cal. coeff
      real scale3                          ! Scaling factor for k1
      real scale4                          ! Scaling factor for k2
      real scale5                          ! Scaling factor for k3
!!!!! data scale3 /1.e-06/
!!!!! data scale4 /1.e-06/
!!!!! data scale5 /1.e-06/

      integer good_qc		           ! Good quality word
      integer bad_qc	                   ! Bad quality word
      integer*4 status_channel             ! avh_h_inststat2 or avh_h_inststat1
      logical first /.true./
      integer vcoefset	                   ! Visible coeff. set

      save                                 ! Save local tables and logical first

!---- EQUIVALENCES -----------------------------------------------------

!---- FUNCTIONS --------------------------------------------------------

      real avh_cir_r                       ! Radiance to brightness temperature
                                           !  conversion (real)

!---- CODE -------------------------------------------------------------

      if (first ) then

! FIRST TIME IN HERE ...

!  Modification to correct lack of accuracy of scaling factors proposed by NOAA
!   ( M. Derrien 26/01/1999)
!   -- must be considered only for a transition, because we do not change the
!      l1bversnb number due to CMS consideration and we don't have the new
!      NESDIS scaling factors.
!      This will change scaling factors only for 1B files whose data are newer
!      than 27 January 1999,12 UTC date where changed at CMS.
!
!       Now avh_filler2(3) stores the 3 exponents of the scaling coefficients.
!       Subroutine avh_lbc will be able to read the new exponents and will
!       suppose exponent 6 for all archived files.  Beware of reading these new
!       files without taking into account the filler2 array.
!  ----------------------------------------------------------------------------

!  Xu Li, 08/16/2005: From NESDIS people (Chao), NOAA satellite data format was
!                     updated on April 28, 2005.
!                     For AVHRR Ch-4 & Ch-5, IR calibration exponent of scaling
!                     coefficient 3 (expon5) has been changed (6 -> 7).
!  ----------------------------------------------------------------------------

         expon3=6
         expon4=6
         expon5=7

         scale3 = 10. ** (-1 *expon3)
         scale4 = 10. ** (-1 *expon4)
         scale5 = 10. ** (-1 *expon5)

!!!!!$        if (avh_h_startdatajd.ge.17923.5) then
!!!!!$          scale3 = 1.e-09
!!!!!$        endif

!  We use the prelaunch coefficients  (indice 3)
!   operationnal set is 1
!   test set is 2
!  ---------------------------------------------

!!!!!!!  vcoefset=3

!  Xu Li, 09/08/2005: change to use operational set (1)
!  ----------------------------------------------------

         vcoefset = 1
         do c = 1, avh_mxvischn
!!!!!!!     slope     = avh_calvis(1,vcoefset,c)*1.e-10
!!!!!!!     intercept = avh_calvis(2,vcoefset,c)*1.e-7

            slope     = avh_calvis(1,vcoefset,c)*1.e-7
            intercept = avh_calvis(2,vcoefset,c)*1.e-6

            do ncount = 0 , avh_calvis(5,vcoefset,c),1
               tabalb(ncount,c) = (slope * float(ncount) + intercept)

               if(tabalb(ncount,c).lt.0.) tabalb(ncount,c)=0.
            enddo
!!!!!!!     slope     = avh_calvis(3,vcoefset,c)*1.e-10
!!!!!!!     intercept = avh_calvis(4,vcoefset,c)*1.e-7

            slope     = avh_calvis(3,vcoefset,c)*1.e-7
            intercept = avh_calvis(4,vcoefset,c)*1.e-6

            do ncount = avh_calvis(5,vcoefset,c), 1023
               tabalb(ncount,c) = (slope * float(ncount) + intercept)

               if(tabalb(ncount,c).lt.0.) tabalb(ncount,c)=0.
            enddo
         enddo

!!!!!    write(*,*) 'tabalb(ncount,1) : '
!!!!!    write(*,'(10F9.2)') (tabalb(ncount,1),ncount=0,1023)

!!!!!    write(*,*) 'tabalb(ncount,2) : '
!!!!!    write(*,'(10F9.2)') (tabalb(ncount,2),ncount=0,1023)

!!!!!    write(*,*) 'tabalb(ncount,3) : '
!!!!!    write(*,'(10F9.2)') (tabalb(ncount,3),ncount=0,1023)

!!!!!    write(*,*) 'counts(1,ncount) : '
!!!!!    write(*,'(15I6)') (counts(1,ncount),ncount=1,mpos)

!!!!!    write(*,*) 'counts(2,ncount) : '
!!!!!    write(*,'(15I6)') (counts(2,ncount),ncount=1,mpos)

!!!!!    write(*,*) 'counts(3,ncount) : '
!!!!!    write(*,'(15I6)') (counts(3,ncount),ncount=1,mpos)

!!!!!    write(*,*) 'counts(4,ncount) : '
!!!!!    write(*,'(15I6)') (counts(4,ncount),ncount=1,mpos)

!!!!!    write(*,*) 'counts(5,ncount) : '
!!!!!    write(*,'(15I6)') (counts(5,ncount),ncount=1,mpos)

!  Infrared channels
!  -----------------

!  C1 and C2 are defined here because the common cavh_cpi has net been
!   initialized (call avh_cpar)
!
!  planck1 is C1 * nu3
!  planck2 is C2 * nu
!  avh_bandcor(1,c) is nu (cm-1)
!  avh_bandcor(2,c) is intercept (K)
!  avh_bandcor(3,c) is slope (K/K)
!  -------------------------------------------------------------------

!  Xu Li: update C1, C2
!
!!!!     C1 = 0.000011910659d0
!!!!     C2 = 1.438833d0

         C1 = 0.000011910427d0
         C2 = 1.4387752d0

!  Planck coefficients channel 3B
!  ------------------------------

         c=1
         nu=avh_h_radtempcnv(1,c)*1.e-02
         planck1(c)=C1*nu*nu*nu
         planck2(c)=C2*nu
         avh_bandcor(1,c)=nu
         avh_bandcor(2,c)=avh_h_radtempcnv(2,c)*1.e-05
         avh_bandcor(3,c)=avh_h_radtempcnv(3,c)*1.e-06

!  Planck coefficients channel 4
!  -----------------------------

         c=2
         nu=avh_h_radtempcnv(1,c)*1.e-03
         planck1(c)=C1*nu*nu*nu
         planck2(c)=C2*nu
         avh_bandcor(1,c)=nu
         avh_bandcor(2,c)=avh_h_radtempcnv(2,c)*1.e-05
         avh_bandcor(3,c)=avh_h_radtempcnv(3,c)*1.e-06

!  Planck coefficients channel 5
!  -----------------------------

         c=3
         nu=avh_h_radtempcnv(1,c)*1.e-03
         planck1(c)=C1*nu*nu*nu
         planck2(c)=C2*nu
         avh_bandcor(1,c)=nu
         avh_bandcor(2,c)=avh_h_radtempcnv(2,c)*1.e-05
         avh_bandcor(3,c)=avh_h_radtempcnv(3,c)*1.e-06

!  Radiance to temperature tables, all IR channels (common temp_conv)
!  ------------------------------------------------------------------

         call avh_icon

         first = .false.
      endif

!  Channel status for the line
!  ---------------------------

      status_channel = avh_h_inststat1

      if (avh_h_statchrecnb.eq.0) then
         status_channel = avh_h_inststat1
      else if(line.ge.avh_h_statchrecnb) then
         status_channel = avh_h_inststat2
      endif

!  MISSING LINE TEST
!  -----------------

      if(ibits(avh_qualind,31,1) == 1 .or. ibits(avh_qualind,30,1) == 1 .or. &
         ibits(avh_qualind,28,1) == 1 .or. ibits(avh_qualind,27,1) == 1 )then

!  Missing line, 0 ==> 5 channels
!  ------------------------------

         do p=1,mpos
            do c=1,5
               avh_bt(c,p)=bmiss
            enddo
         enddo
         do p=1,mpos
            do c=1,5
               avh_rad(c,p)=bmiss
            enddo
         enddo
         missing = 1
         bad_lines(1) = bad_lines(1) + 1
         bad_lines(2) = bad_lines(2) + 1
         bad_lines(3) = bad_lines(3) + 1
         bad_lines(4) = bad_lines(4) + 1
         bad_lines(5) = bad_lines(5) + 1
         bad_lines(6) = bad_lines(6) + 1

      else

!  GOOD LINE
!  ---------

         missing = 0

!  Channel VIS 1
!  =============

         c = 1

!  Testing if the channel is enabled (1)
!  -------------------------------------

         if(ibits(status_channel,13,1).eq.1)then

            good_lines(1) = good_lines(1)+1

!  Loop on mpos pixels
!  -------------------

            do p = 1, mpos
               avh_bt(c,p) = tabalb(counts(c,p),c)
               avh_rad(c,p)= bmiss
            enddo

         else

!  Channel is disabled
!  -------------------

            bad_lines(1) = bad_lines(1) + 1
            do p=1,mpos
               avh_bt(c,p) = bmiss
               avh_rad(c,p) = bmiss
            enddo
         endif

!  Channel VIS 2
!  =============

         c = 2

!  Testing if the channel is enabled (1)
!  -------------------------------------

         if(ibits(status_channel,12,1).eq.1)then

            good_lines(2) = good_lines(2)+1

!  Loop on mpos pixels
!  -------------------

            do p=1,mpos
               avh_bt(c,p)  = tabalb(counts(c,p),c)
                avh_rad(c,p) = bmiss
            enddo

         else

!  Channel is disabled
!  -------------------

            bad_lines(2) = bad_lines(2) + 1
            do p=1,mpos
               avh_bt(c,p) = bmiss
               avh_rad(c,p) = bmiss
            enddo
         endif

!  Channel IR 3B or Channel Vis 3A
!  ===============================

         c = 3

!  Bits 1-0 of avh_scnlinbit : channel 3 select (0 = 3b; 1 = 3a; 2 = transition)
!  -----------------------------------------------------------------------------

         if(ibits(avh_scnlinbit,0,1) == 0)then

!  Testing if the channel 3B is enabled (1)
!  ----------------------------------------

            if(ibits(status_channel,10,1).eq.1)then

!  Testing the calibration quality flag
!  ------------------------------------

               if(ibits(avh_calqual(1),7,1).eq.0)then
                  k1=avh_calir(1,1,1)*scale3
                  k2=avh_calir(2,1,1)*scale4
                  k3=avh_calir(3,1,1)*scale5

                  good_lines(3) = good_lines(3)+1

!  Loop on mpos pixels
!  -------------------

                  do p=1,mpos
                     rcount = float(counts(c,p))
!!!!!!               radiance = k1*rcount*rcount + k2*rcount + k3
                     radiance = k1 + k2*rcount + k3*rcount*rcount
                     avh_rad(c,p) = radiance
                     avh_bt(c,p)=avh_cir_r(radiance,1)
                  enddo

               else

!  Calibration not usable for channel 3B
!  -------------------------------------

                  bad_lines(3) = bad_lines(3) + 1
                  do p=1,mpos
                     avh_rad(c,p) = bmiss
                     avh_bt(c,p)  = bmiss
                  enddo

               endif

            else

!  Channel is disabled
!  -------------------

               bad_lines(3) = bad_lines(3) + 1
               do p=1,mpos
                  avh_rad(c,p) = bmiss
                  avh_bt(c,p)  = bmiss
               enddo
            endif

         elseif ( ibits(avh_scnlinbit,0,1) == 1) then

!  Bits 1-0 of avh_scnlinbit : channel 3 select (0 = 3b; 1 = 3a; 2 = transition)
!  -----------------------------------------------------------------------------

!  Channel IR 3A
!  =============

!  Testing if the channel 3A is enabled (1)
!  ----------------------------------------

            if(ibits(status_channel,11,1).eq.1)then

               good_lines(6) = good_lines(6)+1

!  Loop on mpos pixels
!  -------------------

               do p=1,mpos
                  avh_bt(c,p)  = tabalb(counts(c,p),3)
                  avh_rad(c,p) = bmiss
               enddo

            else

!  Channel is disabled
!  -------------------

               bad_lines(6) = bad_lines(6) + 1
               do p=1,mpos
                  avh_bt(c,p)  = bmiss
                  avh_rad(c,p) = bmiss
               enddo
            endif

         endif

!  Channel IR 4
!  ============

         c = 4

!  Testing if the channel is enabled (1)
!  -------------------------------------

         if(ibits(status_channel,9,1).eq.1)then

!  Testing the calibration quality flag
!  ------------------------------------

            if(ibits(avh_calqual(2),7,1).eq.0)then
               k1=avh_calir(1,1,2)*scale3
               k2=avh_calir(2,1,2)*scale4
               k3=avh_calir(3,1,2)*scale5

               good_lines(4) = good_lines(4)+1

!  Loop on mpos pixels
!  -------------------

               do p=1,mpos
                  rcount = float(counts(c,p))
!!!!!             radiance = k1*rcount*rcount + k2*rcount + k3
                  radiance = k1 + k2*rcount + k3*rcount*rcount
                  avh_rad(c,p) = radiance
                  avh_bt(c,p)=avh_cir_r(radiance,2)

               enddo
            else

!  Calibration not usable
!  ----------------------

               bad_lines(4) = bad_lines(4) + 1
               do p=1,mpos
                  avh_rad(c,p) = bmiss
                  avh_bt(c,p)  = bmiss
               enddo
            endif
         else

!  Channel is disabled
!  -------------------

            bad_lines(4) = bad_lines(4) + 1
            do p=1,mpos
               avh_rad(c,p) = bmiss
               avh_bt(c,p)  = bmiss
            enddo
         endif

!  Channel IR 5
!  ============

         c = 5

!  Testing if the channel is enabled (1)
!  -------------------------------------

         if(ibits(status_channel,8,1).eq.1)then

!  Testing the calibration quality flag
!  ------------------------------------

            if(ibits(avh_calqual(3),7,1).eq.0)then

               k1=avh_calir(1,1,3)*scale3
               k2=avh_calir(2,1,3)*scale4
               k3=avh_calir(3,1,3)*scale5

               good_lines(5) = good_lines(5)+1

!  Loop on mpos pixels
!  -------------------

               do p=1,mpos
                  rcount = float(counts(c,p))
!!!!!             radiance = k1*rcount*rcount + k2*rcount + k3
                  radiance = k1 + k2*rcount + k3*rcount*rcount

                  avh_rad(c,p) = radiance
                  avh_bt(c,p)=avh_cir_r(radiance,3)

               enddo
            else

!  Calibration not usable
!  ----------------------

               bad_lines(5) = bad_lines(5) + 1
               do p=1,mpos
                  avh_rad(c,p) = bmiss
                  avh_bt(c,p)  = bmiss
               enddo
            endif
         else

!  Channel is disabled
!  -------------------

            bad_lines(5) = bad_lines(5) + 1
            do p=1,mpos
               avh_rad(c,p) = bmiss
               avh_bt(c,p)  = bmiss
            enddo
         endif

      endif

      good_qc = 0
      if(missing == 0) then
         do p=1,mpos
            avh_qc(p) = good_qc		! good line
         end do
      else

         bad_qc = ibset(good_qc,bit_qc)

         print*,'missing AVHRR line',line

         do p = 1, mpos
            avh_qc(p) = bad_qc   	! missing line
         end do
      endif

      END SUBROUTINE GAC_LBC

      SUBROUTINE AVH_ICON
!$$$  MAIN PROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM: AVH_ICON
!   PRGMMR: KEYSER           ORG: NP22        DATE: 2006-10-19
!
! ABSTRACT: Initializes lookup tables to convert radiances into temperature for
!   the 3 AVHRR IR channels.
!
! PROGRAM HISTORY LOG:
! 1995-09-01  Marcel Derrien   Original author
! 2003-01-14  Xu Li            ????
! 2006-10-19  Keyser           Improved docblocks and comments
!
! USAGE: CALL AVH_ICON
!
! REMARKS: None
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90 (free format)
!   MACHINE:  NCEP WCOSS
!
!$$$
      implicit none

!  DECLARATIONS
!  ------------

      character*62 sccsid

      data sccsid/'@(#) avh_icon.F version 1.1 on 3/24/98'/

!  COMMONS
!  -------

      include 'cavh_cpi.inc'
      real rbeg(3),rstep(3),rend(3)
      real tconv(4000,3)
      common/temp_conv/rbeg,rstep,rend,tconv

!  Local variables
!  ---------------

      real r
      integer i
      integer c
      integer ios

!  FUNCTIONS
!  ---------

      real avh_brig

      rbeg(1)=1.e-4

      rbeg(2)=1.
      rbeg(3)=1.
      rstep(1)=5.e-04
      rstep(2)=0.1
      rstep(3)=0.1
      do i = 1 , 3
         rend(i)=rbeg(i) + 3999.* rstep(i)
      enddo
      do i = 1,4000
         do c = 1,3
            r = rbeg(c) + (i-1)* rstep(c)
            tconv(i,c) = avh_brig(r,c,ios)
         enddo
      enddo

      END SUBROUTINE AVH_ICON

      SUBROUTINE LAG(Y,IMODE)
!$$$  MAIN PROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM: LAG
!   PRGMMR: KEYSER           ORG: NP22        DATE: 2006-10-19
!
! ABSTRACT: Given selected parameter (solar zenith angle, satellite zenith
!   angle, relative azuimuth angle,lat,lon) on 51 spaced-apart pixels in one
!   AVHRR GAC scan, inteprolates parameter to all pixels in scan.
!
! PROGRAM HISTORY LOG:
! 2003-01-14  Xu Li            Original author
! 2006-10-19  Keyser           Improved docblocks and comments
!
! USAGE: CALL LAG(Y,IMODE)
!   INPUT ARGUMENTS:
!     Y      - Parameter with values on 51 spaced-apart pixels
!     IMODE  - Identifies case where parameter passed in (Y) is longitude (=1)
!              since extra logic is invoked (this is set to 0 for all other
!              parameters)
!
!   OUTPUT ARGUMENTS:
!     Y      - Parameter with values on all pixels (via interpolation)
!
! REMARKS: NONE
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90 (free format)
!   MACHINE:  NCEP WCOSS
!
!$$$

      implicit none

      integer, parameter :: n1=5, dn=8
      real, dimension(mpos) :: y0,y

      integer :: n0,n,imode,domd
      real :: L,max

!  Lagrangian interpolation for the pixels between n1 + 1 = 6 and mpos/2  = 204
!  ----------------------------------------------------------------------------

                         ! n0 = 13, 29, 45, ... , 173,189
      do n0 = n1 + dn , mpos/2, 2*dn
                         ! n  = (6...11 12 14...19 20)... (182...188,190...196)
         do n = n0 - (dn - 1), n0 + (dn - 1)
            if ( n /= n0 ) then
               y(n) = 0.0
               max = -99999.0
               do i = n0 - dn , n0 + dn, dn
                  if ( y(i) >= max ) then
                     max = y(i)
                  endif
               enddo
               do i = n0 - dn , n0 + dn, dn
                  L = 1.0
                  do j = n0 - dn , n0 + dn, dn
                     if (j /= i ) then
                        L = L*real(n-j)/real(i-j)
                     endif
                  enddo

!  Handle transition across dateline {abs(slon) close to 180 and sign changes}
!  ---------------------------------------------------------------------------

                  y0(i) = y(i)
                  if ( y0(i) < -50.0 .and. imode == 1 .and. max > 0.0 ) then
                     y0(i) = y0(i) + 360.0
                  endif
                  y(n) = y(n) + L*y0(i)
               enddo
               if ( imode == 1 ) then
                  if ( y(n) > 180.0 ) then
                     y(n) = y(n) - 360.0
                  elseif ( y(n) < -180.0 ) then
                     y(n) = y(n) + 360.0
                  endif
               endif
            endif
         enddo
      enddo

!  Lagrangian interpolation for the pixels between mpos/2 - 1 = 404 and
!   mpos/2 + dn  = 214
!  --------------------------------------------------------------------

                         ! n0 = 397, 381,  ..., 237,221
                         ! n = (404...398 396... 390)... (228...222,220...214)
      do n0 = mpos -dn/2 - dn , mpos/2 + 2, -2*dn
         do n = n0 + (dn - 1), n0 - (dn - 1), -1
            if ( n /= n0 ) then
               y(n) = 0.0
               max = -99999.0
               do i = n0 + dn , n0 - dn, -dn
                  if ( y(i) >= max ) then
                     max = y(i)
                  endif
               enddo
               do i = n0 + dn , n0 - dn, -dn
                  L = 1.0
                  do j = n0 + dn , n0 - dn, -dn
                     if (j /= i ) then
                        L = L*real(n-j)/real(i-j)
                      endif
                  enddo

!  Handle transition across dateline {abs(slon) close to 180 and sign changes}
!  ---------------------------------------------------------------------------

                  y0(i) = y(i)
                  if ( y0(i) < -50.0 .and. imode == 1 .and. max > 0.0 ) then
                     y0(i) = y0(i) + 360.0
                  endif
                  y(n) = y(n) + L*y0(i)
               enddo
               if ( imode == 1 ) then
                  if ( y(n) > 180.0 ) then
                     y(n) = y(n) - 360.0
                  elseif ( y(n) < -180.0 ) then
                     y(n) = y(n) + 360.0
                  endif
               endif
            endif
         enddo
      enddo

!  5-point Lagrangian extrapolation for the begining pixels n = 1 - 4
!  ------------------------------------------------------------------

      do n = 1, n1 - 1
         y(n) = 0.0
         max = -99999.0
         do i = n1, n1 + 4*dn, dn                     ! 5 13 21 29 37 45
            if ( y(i) >= max ) then
               max = y(i)
            endif
         enddo
         do i = n1, n1 + 4*dn, dn                     ! 5 13 21 29 37 45
            L = 1.0
            do j = n1, n1 + 4*dn, dn
               if (j /= i ) then
                  L = L*real(n-j)/real(i-j)
               endif
            enddo

!  Handle transition across dateline {abs(slon) close to 180 and sign changes}
!  ---------------------------------------------------------------------------

            y0(i) = y(i)
            if ( y0(i) < -50.0 .and. imode == 1 .and. max > 0.0 ) then
               y0(i) = y0(i) + 360.0
            endif
            y(n) = y(n) + L*y0(i)
         enddo
         if ( imode == 1 ) then
            if ( y(n) > 180.0 ) then
               y(n) = y(n) - 360.0
            elseif ( y(n) < -180.0 ) then
               y(n) = y(n) + 360.0
            endif
         endif
      enddo

!  3-point Lagrangian interpolation for the pixels (198, ..., 204)
!  ---------------------------------------------------------------

      do n = mpos/2 - dn + 2, mpos/2                  ! 198 - 204
         y(n) = 0.0
         max = -99999.0
         do i = mpos/2 + 1 - 2*dn, mpos/2 + 1, dn     ! 189,197,205
            if ( y(i) >= max ) then
               max = y(i)
            endif
         enddo
         do i = mpos/2 + 1 - 2*dn, mpos/2 + 1, dn     ! 189,197,205
            L = 1.0
            do j = mpos/2 + 1 - 2*dn, mpos/2 + 1, dn  ! 189,197,205
               if (j /= i ) then
                  L = L*real(n-j)/real(i-j)
               endif
            enddo

!  Handle transition across dateline {abs(slon) close to 180 and sign changes}
!  ---------------------------------------------------------------------------

            y0(i) = y(i)
            if ( y0(i) < -50.0 .and. imode == 1 .and. max > 0.0 ) then
               y0(i) = y0(i) + 360.0
            endif
            y(n) = y(n) + L*y0(i)
         enddo
         if ( imode == 1 ) then
            if ( y(n) > 180.0 ) then
               y(n) = y(n) - 360.0
            elseif ( y(n) < -180.0 ) then
               y(n) = y(n) + 360.0
            endif
         endif
      enddo

!  3-point Lagrangian interpolation for the pixels (206, ..., 212)
!  ---------------------------------------------------------------

      do n = mpos/2 + 2, mpos/2 + dn                  ! 206 - 212
         y(n) = 0.0
         max = -99999.0
         do i = mpos/2 + 1, mpos/2 + 1 + 2*dn, dn     ! 205,213,221
            if ( y(i) >= max ) then
               max = y(i)
            endif
         enddo
         do i = mpos/2 + 1, mpos/2 + 1 + 2*dn, dn     ! 205,213,221
            L = 1.0
            do j = mpos/2 + 1, mpos/2 + 1 + 2*dn, dn  ! 205,213,221
               if (j /= i ) then
                  L = L*real(n-j)/real(i-j)
               endif
            enddo

!  Handle transition across dateline {abs(slon) close to 180 and sign changes}
!  ---------------------------------------------------------------------------

           y0(i) = y(i)
           if ( y0(i) < -50.0 .and. imode == 1 .and. max > 0.0 ) then
              y0(i) = y0(i) + 360.0
           endif
           y(n) = y(n) + L*y0(i)
        enddo
        if ( imode == 1 ) then
           if ( y(n) > 180.0 ) then
              y(n) = y(n) - 360.0
           elseif ( y(n) < -180.0 ) then
              y(n) = y(n) + 360.0
           endif
        endif
     enddo

!  5-point Lagrangian extrapolation for the ending pixels (406-mpos)
!  -----------------------------------------------------------------

     do n = mpos - dn/2 + 1, mpos
        y(n) = 0.0
        max = -99999.0
        do i = mpos - dn/2 - 4*dn , mpos - dn/2 , dn
           if ( y(i) >= max ) then
              max = y(i)
           endif
        enddo
        do i = mpos - dn/2 - 4*dn , mpos - dn/2 , dn
           L = 1.0
           do j = mpos - dn/2 - 4*dn , mpos - dn/2 , dn
              if (j /= i ) then
                 L = L*real(n-j)/real(i-j)
              endif
           enddo

!  Handle transition across dateline {abs(slon) close to 180 and sign changes}
!  ---------------------------------------------------------------------------

           y0(i) = y(i)
           if ( y0(i) < -50.0 .and. imode == 1 .and. max > 0.0 ) then
              y0(i) = y0(i) + 360.0
           endif
           y(n) = y(n) + L*y0(i)
        enddo
        if ( imode == 1 ) then
           if ( y(n) > 180.0 ) then
              y(n) = y(n) - 360.0
           elseif ( y(n) < -180.0 ) then
              y(n) = y(n) + 360.0
           endif
        endif
     enddo

     END SUBROUTINE LAG

     SUBROUTINE DATTIM(IDT,NDT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
! SUBPROGRAM:    DATTIM
!   PRGMMR: Katz             ORG: NP2        DATE: 1997-11-06
!
! ABSTRACT: Converts year, day-of-year, and second-of-day into year,
!   month-of-year, day-of-month, hour-of-day, minute-of-hour, and
!   second-of-minute.
!
! PROGRAM HISTORY LOG:
! 1997-11-06  Katz  Original author
!
! USAGE:    CALL DATTIM(IDT,NDT)
!   INPUT ARGUMENT LIST:
!     IDT      - Integer array argument containing three members:
!                year, day-of-year, and second-of-day
!
!   OUTPUT ARGUMENT LIST:
!     KDT      - Integer array argument containing six members:
!                year, month-of-year, day-of-month, hour-of-day,
!                minute-of-hour, and second-of-minute
!
! Remarks:
!
! Attributes:
!   Language: FORTRAN 90 (free format)
!   Machine:  NCEP WCOSS
!
!$$$

!  Array arguments ..
!  ------------------

      integer idt(3),ndt(6)

      integer :: julian

!  Local scalars ..
!  ----------------

      integer :: iday,imon,iyr,jday,jda,idyr,idaywk,idayyr
      integer :: kyr,idy,jdn,jmo

!  External subroutines ..
!  -----------------------

      external w3fs26

!  Intrinsic functions ..
!  ----------------------

      intrinsic mod

      julian(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4   &
                          -3 * ((IYR + 4899) / 100) / 4 + IDYR

      iyr  = idt(3)
      jday = idt(2)

!  If year is two digits, convert to 4 digits
!  ------------------------------------------

      if (iyr.ge.0.and.iyr.le.99) then
         if (iyr.lt.21) then
            kyr = iyr + 2000
         else
            kyr = iyr + 1900
         endif
      else
         kyr = iyr
      endif

!  Compute Julian day number as number days after 4713 BC
!  ------------------------------------------------------

      idy = jday
      jdn = julian(kyr,idy)

      call w3fs26(jdn,iyear,jmo,jda,idaywk,idayyr)

      ndt(1) = iyr
      ndt(2) = jmo
      ndt(3) = jda
      ndt(4) = idt(1)/3600
      ndt(5) = mod(idt(1),3600)/60
      ndt(6) = idt(1) - 3600*ndt(4) - 60*ndt(5)

      END SUBROUTINE DATTIM

END MODULE GAC_1B_PROC


! @Copyright 2007 Kristjan Haule
!

SUBROUTINE cmp_MT_density(w_RHOLM, Aweight, wEpsw, weight, fsph, fnsp, fsph2, nemin, nemax, DM_nemin, DM_nemax, DM_nemaxx, nbands, nbandsx, nbands_dft, lm_max, n0, nnlo, coord, ikp, DM_EF, time_bl,time_bl_w, time_reduc, time_reduc_w, time_radprod, time_radprod_w,time_m, time_m_w, time_rad, time_rad_w, time_ilm, time_ilm_w, time_lo, time_lo_w, time_force, time_force_w)
  USE defs,  ONLY: pi, imag
  USE param, ONLY: lmax2, nume, nloat, iblock, nmat, nrad, CHUNK, lomax, ngau
  USE atspdt,ONLY: p, dp, pe, dpe, el
  USE com,   ONLY: nat, rel
  USE lo,    ONLY: nlo, nlov, nlon, lapw, ilo, loor, a1lo, b1lo, elo
  USE lohelp,ONLY: u21, ue21, u12, ue12, u22, sum12, sum21, sum22, sume21, sume12, zerotc_lohelp
  USE structure, ONLY: Rmt, vol, mult, rotij, br1, pos, tauij, jri, rotloc, natm
  USE xa,    ONLY: TC100, TCA100, TCB100, LM, E, SUMA, SUMB, SUMAB, SUMBA
  USE w_atpar, ONLY: w_xwt1, w_xwt1l, w_xwt1h, w_xwteh, w_xwtel, retrieve_w_atpar, Vts, lpv, lv, mpv, mv, Nhmx
  USE dmfts, ONLY: iso, shft
  USE charp, ONLY: zero_charp
  USE chard, ONLY: zero_chard
  USE charf, ONLY: zero_charf
  USE w_atpar,ONLY: ri_mat, ul_Rmt, dul_Rmt
  USE alm_blm_clm, ONLY: cmp_alm_blm_clm
  USE Forces, ONLY: Force1_corrected, Force1_DMFT, Force2, Force3, forcea, Qforce !, Force5_mine
  USE com_mpi, ONLY : myrank, master
  IMPLICIT NONE
  REAL*8, intent(out)    :: w_RHOLM(NRAD,LM_MAX,nat)!, w_vRHOLM(NRAD,LM_MAX,nat)
  INTEGER, intent(in)    :: nemin, nemax, DM_nemin, DM_nemax, DM_nemaxx, nbands, nbandsx, nbands_dft, lm_max, n0, nnlo, ikp
  COMPLEX*16, intent(in) :: Aweight(nbands,nbands), wEpsw(nbands_dft,nbands_dft)
  REAL*8, intent(in)     :: weight(nume), DM_EF
  REAL*8, intent(inout)  :: time_bl, time_bl_w, time_reduc, time_reduc_w, time_radprod, time_radprod_w, time_m, time_m_w, time_rad, time_rad_w, time_ilm, time_ilm_w, time_lo, time_lo_w, time_force, time_force_w
  CHARACTER*5, intent(in):: coord
  REAL*8,PARAMETER       :: Ry2eV= 13.60569253d0
  !
  REAL*8, intent(inout) :: fsph(3,natm)
  REAL*8, intent(inout) :: fnsp(3,natm)
  REAL*8, intent(inout) :: fsph2(3,natm)
  !
  Interface
     integer FUNCTION NOTRI(k,l,m)
       integer, intent(in) :: k,l,m
     end FUNCTION NOTRI
     real*8 FUNCTION GAUNT(l1,l2,l3,mm1,mm2,mm3)
       integer, intent(in) :: l1,l2,l3,mm1,mm2,mm3
     end FUNCTION GAUNT
     SUBROUTINE YLM(V,LMAX,Y)
       COMPLEX*16, intent(out)      :: Y(*)
       INTEGER, intent(in)          :: LMAX
       DOUBLE PRECISION, intent(in) :: V(3)
     end SUBROUTINE YLM
  end interface
  ! commons
  COMMON /RADFU/  RRAD1(NRAD,0:LMAX2),RADE1(NRAD,0:LMAX2),RRAD2(NRAD,0:LMAX2),RADE2(NRAD,0:LMAX2)
  REAL*8     :: RRAD1, RADE1, RRAD2, RADE2
  COMMON /UHELP/  UA(NRAD),UB(NRAD),UBA(NRAD),UAB(NRAD)
  REAL*8     :: UA, UB, UBA, UAB
  ! locals
  COMPLEX*16, ALLOCATABLE :: alm(:,:),blm(:,:),clm(:,:,:), dh_alm(:,:,:), dh_blm(:,:,:), dh_clm(:,:,:,:)
  COMPLEX*16 :: imag1, gint, wkp
  INTEGER :: jatom, lfirst, lmmax, mmax, latom, mu, is, i, l, m, lmx, l1, ilm, li, mi, lp, lp1, mpmax, imax
  INTEGER :: jlo, jlop, num, mp, ms, mps, mtest, ly, lpy, jatombad, lbad, lmax2lmax2, lomaxlomax
  REAL*8  :: CIN, test1, eqbad!, facv
  REAL*8  :: time1, time1_w, time2, time2_w, time3, time3_w, time4, time4_w
  COMPLEX*16 :: sa, sb, sab, sba, tsuma, tsumb, tsumab, tsumba!, vsa, vsb, vsab, vsba
  COMPLEX*16 :: s12(nloat), se12(nloat), s21(nloat), se21(nloat), s22(nloat,nloat)
  !COMPLEX*16 :: vs12(nloat), vse12(nloat), vs21(nloat), vse21(nloat), vs22(nloat,nloat)
  COMPLEX*16 :: tsum21(nloat), tsume21(nloat), tsum12(nloat), tsume12(nloat), tsum22(nloat,nloat)
  COMPLEX*16 :: tsa, tsb, tsab, tsba, ts12(nloat), tse12(nloat), ts21(nloat), tse21(nloat), ts22(nloat,nloat)
  REAL*8     :: tc_buf(nrad)!,vtc_buf(nrad)
  LOGICAL    :: Qforce_j
  COMPLEX*16, ALLOCATABLE :: aalm(:,:,:), bblm(:,:,:), cclm(:,:,:,:)
  REAL*8, allocatable :: GNT(:,:)
  CHARACTER*20 :: cstr
  INTEGER    :: j, ik
  INTEGER    :: lmax2lmax2_,nbands_dft_,dim_,lomaxlomax_,nloat_

  lmax2lmax2 = (LMAX2+1)*(LMAX2+1)
  lomaxlomax = (lomax+1)*(lomax+1)
  LMX=LMAX2
  CIN=1.d0/137.0359895d0**2
  IF (.NOT.REL) CIN=4.0*1.0D-22

  !nbands_dft = nemax-nemin+1

  test1=0.0d0
  ALLOCATE(alm(lmax2lmax2,nume),blm(lmax2lmax2,nume),clm(lomaxlomax,nume,nloat))
  ALLOCATE( dh_alm(iso,lmax2lmax2,nume), dh_blm(iso,lmax2lmax2,nume), dh_clm(nloat,iso,lomaxlomax,nume) )

  if (Qforce) then
     lmax2lmax2_ = lmax2lmax2
     nbands_dft_ = nbands_dft
     dim_ = 3
     lomaxlomax_ = lomaxlomax
     nloat_ = nloat
  else
     ! the arrays need to be always allocated
     lmax2lmax2_ = 1
     nbands_dft_ = 1
     dim_ = 1
     lomaxlomax_ = 1
     nloat_ = 1
  endif
  ALLOCATE( aalm(lmax2lmax2_,nbands_dft_,dim_), bblm(lmax2lmax2_,nbands_dft_,dim_), cclm(lomaxlomax_,nbands_dft_,nloat_,dim_) )

  do jatom=1,nat
     ! Quantities computed by "atpar" which do not depend on k-point
     CALL retrieve_w_atpar(jatom,lfirst,lmmax)
     ! zero koeff. for charge analysis
     CALL zero_charp(nemin,nemax)
     CALL zero_chard(nemin,nemax)
     CALL zero_charf(nemin,nemax)
     CALL zerotc_lohelp(nemin,nemax)
     TC100(0:lmax2,nemin:nemax)=0.0d0
     TCA100(0:lmax2,nemin:nemax)=0.0d0
     TCB100(0:lmax2,nemin:nemax)=0.0d0

     ! CALCULATE ALM, BLM
     latom=lfirst-1

     Qforce_j = Qforce .AND. forcea(0,jatom)

     DO mu=1,mult(jatom)
        latom=latom+1
        DO is=1,iso !!! over spin: Mar 25, 2010

           CALL cputim(time1)
           CALL walltim(time1_w)
           !CALL cmp_alm_blm_clm(alm,blm,clm,aalm,bblm,cclm,Aweight,latom,lfirst,jatom,nemin,nemax,n0,nnlo,is,DM_nemin,DM_nemax,DM_nemaxx,nbands,nbandsx,Qforce_j,lmax2lmax2_,nbands_dft_,dim_,lomaxlomax_,nloat_,time_bl,time_bl_w,time_lo,time_lo_w)
           CALL cmp_alm_blm_clm(alm,blm,clm,aalm,bblm,cclm,Aweight,latom,lfirst,jatom,nemin,nemax,n0,nnlo,is,DM_nemin,DM_nemax,DM_nemaxx,nbands,nbandsx,Qforce_j,time_bl,time_bl_w,time_lo,time_lo_w)

           dh_alm(is,:,:) = alm(:,:)
           dh_blm(is,:,:) = blm(:,:)
           DO jlo=1,nloat
              dh_clm(jlo,is,:,:) = clm(:,:,jlo)
           ENDDO

           CALL cputim(time2)
           CALL walltim(time2_w)

           ! MAIN FORCE CALCULATIONS
           if (Qforce_j) then
              !fsph(:,latom)  = fsph(:,latom)  + Force1(nemin,nemax,DM_nemaxx,lmx,alm,blm,clm,aalm,bblm,cclm,weight,el,elo,E,ri_mat(:,:,:,jatom),ilo,lmax2,nume,nloat,lomax,nbands_dft)
              !fsph(:,latom)  = fsph(:,latom)  + Force1_corrected(nemin,nemax,DM_nemaxx,lmx,alm,blm,clm,aalm,bblm,cclm,weight,el,elo,E,ri_mat(:,:,:,jatom),ilo,lmax2,nume,nloat,lomax,nbands_dft)
              fsph(:,latom)  = fsph(:,latom)  + Force1_DMFT(nemin,nemax,DM_nemaxx,lmx,alm,blm,clm,aalm,bblm,cclm,weight,el,elo,wEpsw,ri_mat(:,:,:,jatom),ilo,lmax2,nume,nloat,lomax,nbands_dft,nbands)
              fnsp(:,latom)  = fnsp(:,latom)  + Force2(nemin,nemax,DM_nemaxx,Nhmx(jatom),alm,blm,clm,aalm,bblm,cclm,weight,Vts(:,:,:,jatom),lv(:,jatom),lpv(:,jatom),mv(:,jatom),mpv(:,jatom),ilo,lmax2,lomax,nume,nloat,ngau,nbands_dft)
              fsph2(:,latom) = fsph2(:,latom) + Force3(nemin,nemax,DM_nemaxx,lmx,alm,blm,clm,aalm,bblm,cclm,weight,ul_Rmt(:,:,jatom),dul_Rmt(:,:,jatom),Rmt(jatom),ilo,lmax2,lomax,nume,nloat,nbands_dft)
           endif

           CALL cputim(time3)
           CALL walltim(time3_w)
           time_reduc=time_reduc+time2-time1
           time_reduc_w=time_reduc_w+time2_w-time1_w
           time_force=time_force+time3-time2
           time_force_w=time_force_w+time3_w-time2_w
        enddo  !!! Mar 27, 2010: loop over spin

        !! Mar 27, 2010: we need alm for csplit below. Take the average between up and down
        if (iso.eq.2) then
           alm(:,:) = (dh_alm(1,:,:)+dh_alm(2,:,:))/2.
           blm(:,:) = (dh_blm(1,:,:)+dh_blm(2,:,:))/2.
           DO jlo=1,nloat
              clm(:,:,jlo) = (dh_clm(jlo,1,:,:)+dh_clm(jlo,2,:,:))/2.
           ENDDO
        endif

        !.....C(L,M) TO BE CALCULATED
        CALL cputim(time1)
        CALL walltim(time1_w)

        DO ILM=1,LMMAX
           Li=IABS(LM(1,ILM))
           Mi=LM(2,ILM)
           !     SEE KURKI-SUONI  FACTOR FOR  LM+ (1,0), LM-(0,-1), M.NE.2N *(-1)
           IMAG1=(1.0d0,0.0d0)
           IF(LM(1,ILM).LT.0) IMAG1= IMAG   ! (1,i)*(-1)**m for s=(1,-1)
           IF(MOD(Mi,2).EQ.1) IMAG1=-IMAG1  ! (-1)^m*i

           l_sum: DO L=0,lmx
              L1=L+1
              MMAX=2*L+1
              lp_sum: DO LP=0,lmx
                 IF(NOTRI(Li,L,LP).LT.0) CYCLE

                 CALL cputim(time3)
                 CALL walltim(time3_w)
                 ! It is a good idea to recompute gaunt coefficients for this case as it takes some time to compute for each band.
                 allocate( GNT(-L:L, -LP:LP) )
                 GNT(:,:)=0.d0
                 do M=-L,L
                    do MP=-LP,LP
                       if (MP .EQ. M-Mi) GNT(M,MP) = GAUNT(L,Li,LP,M,Mi,MP)
                    enddo
                 enddo

                 LP1=LP+1
                 MPMAX=2*LP+1
                 IMAX=JRI(JATOM)
                 ! Radial functions are constructed
                 DO I=1,IMAX
                    UA(I) =RRAD1(I,L)*RRAD1(I,LP)+CIN*RRAD2(I,L)*RRAD2(I,LP)
                    UB(I) =RADE1(I,L)*RADE1(I,LP)+CIN*RADE2(I,L)*RADE2(I,LP)
                    UAB(I)=RRAD1(I,L)*RADE1(I,LP)+CIN*RRAD2(I,L)*RADE2(I,LP)
                    UBA(I)=RRAD1(I,LP)*RADE1(I,L)+CIN*RRAD2(I,LP)*RADE2(I,L)
                 ENDDO
                 ! Radial functions as product of local orbitals and u,dot{u}
                 DO jlo=1,ilo(l)
                    IF(loor(jlo,l)) THEN
                       DO I=1,IMAX
                          U21(I,jlo) =a1lo(I,jlo,L)*RRAD1(I,LP)+CIN*b1lo(I,jlo,L)*RRAD2(I,LP)
                          Ue21(I,jlo)=a1lo(I,jlo,L)*RADE1(I,LP)+CIN*b1lo(I,jlo,L)*RADE2(I,LP)
                       ENDDO
                    ENDIF
                 ENDDO
                 DO jlop=1,ilo(lp)
                    IF(loor(jlop,lp)) THEN
                       DO i=1,imax
                          u12(i,jlop) =RRAD1(i,l)*a1lo(i,jlop,lp)+CIN*RRAD2(i,l)*b1lo(i,jlop,lp)
                          ue12(i,jlop)=RADE1(i,l)*a1lo(i,jlop,lp)+CIN*RADE2(i,l)*b1lo(i,jlop,lp)
                       ENDDO
                    ENDIF
                 ENDDO
                 ! Radial functions for local orbitals
                 DO jlo=1,ilo(l)
                    DO jlop=1,ilo(lp)
                       IF(loor(jlo,l).AND.loor(jlop,lp)) THEN
                          DO i=1,imax
                             u22(i,jlop,jlo)=a1lo(i,jlo,l)*a1lo(i,jlop,lp)+cin*b1lo(i,jlo,l)*b1lo(i,jlop,lp)
                          ENDDO
                       ENDIF
                    ENDDO
                 ENDDO
                 CALL cputim(time4)
                 CALL walltim(time4_w)
                 time_radprod=time_radprod+time4-time3
                 time_radprod_w=time_radprod_w+time4_w-time3_w
                 !.....M SUM

                 sa=0.0d0; sb=0.0d0; sab=0.0d0; sba=0.0d0; s12=0.0d0;
                 se12=0.0d0; s21=0.0d0; se21=0.0d0; s22=0.0d0

                 CALL cputim(time3)
                 CALL walltim(time3_w)

!!! This loop takes really a lot of time, but the multithreading is dissabled, because the code can corredump.
!!! You should debug this very carefully.
                 !$OMP PARALLEL DO SHARED(suma,sumb,sumab,sumba,sum21,sume21,sum12,sume12,sum22,GNT)&
                 !$OMP& PRIVATE(num,M,MP,MS,MPS,MTEST,LY,LPY,is,gint,tsuma,tsumb,tsumab,tsumba,tsum21,tsume21,tsum12,tsume12,tsum22,tsa,tsb,tsab,tsba,ts21,tse21,ts12,tse12,ts22,wkp)&
                 !$OMP& SCHEDULE(STATIC,CHUNK) &
                 !$OMP& REDUCTION(+:sa,sb,sab,sba,s21,se21,s12,se12,s22)
                 DO num=nemin,DM_nemaxx
                    tsuma = 0.0d0; tsumb = 0.0d0; tsumab= 0.0d0; tsumba= 0.0d0
                    tsum21 (:ilo(l))  = 0.0d0;  tsume21(:ilo(l))  = 0.0d0
                    tsum12 (:ilo(lp)) = 0.0d0;  tsume12(:ilo(lp)) = 0.0d0
                    tsum22 (:ilo(lp),:ilo(l))=0.0d0
                    M=-(L+1)
                    MP=-(LP+1)
                    DO MS=1,2*L+1
                       M=M+1
                       MP=-LP1
                       DO MPS=1,2*LP+1
                          MP=MP+1
                          MTEST=-M+Mi+MP
                          IF(MTEST.NE.0) CYCLE
                          LY  = L*(L+1)+M+1
                          LPY = LP*(LP+1)+MP+1
                          ! GNT=GAUNT(L,Li,LP,M,Mi,MP)
                          gint = IMAG1*GNT(M,MP)
                          do is=1,iso
                             tSA = dh_alm(is,LY,num)*dconjg(dh_alm(is,LPY,num))*gint
                             tSB = dh_blm(is,LY,num)*dconjg(dh_blm(is,LPY,num))*gint
                             tSAB= dh_alm(is,LY,num)*dconjg(dh_blm(is,LPY,num))*gint
                             tSBA= dh_blm(is,LY,num)*dconjg(dh_alm(is,LPY,num))*gint
                             DO jlo=1,ilo(l)
                                tS21(jlo)  = dh_clm(jlo,is,LY,num)*dconjg(dh_alm(is,LPY,num))*gint
                                tSe21(jlo) = dh_clm(jlo,is,LY,num)*dconjg(dh_blm(is,LPY,num))*gint
                             ENDDO
                             DO jlop=1,ilo(lp)
                                tS12(jlop)  = dh_alm(is,LY,num)*dconjg(dh_clm(jlop,is,LPY,num))*gint
                                tSe12(jlop) = dh_blm(is,LY,num)*dconjg(dh_clm(jlop,is,LPY,num))*gint
                             ENDDO
                             DO jlo=1,ilo(l)
                                DO jlop=1,ilo(lp)
                                   tS22(jlop,jlo) = dh_clm(jlo,is,LY,num)*dconjg(dh_clm(jlop,is,LPY,num))*gint
                                ENDDO
                             ENDDO

                             tSUMA  = tSUMA  + tSA/iso
                             tSUMB  = tSUMB  + tSB/iso
                             tSUMAB = tSUMAB + tSAB/iso
                             tSUMBA = tSUMBA + tSBA/iso
                             DO jlo=1,ilo(l)
                                tSUM21 (jlo) = tSUM21 (jlo) + tS21 (jlo)/iso
                                tSUMe21(jlo) = tSUMe21(jlo) + tSe21(jlo)/iso
                             ENDDO
                             DO jlop=1,ilo(lp)
                                tSUM12 (jlop) = tSUM12 (jlop) + tS12(jlop)/iso
                                tSUMe12(jlop) = tSUMe12(jlop) + tSe12(jlop)/iso
                             ENDDO
                             DO jlo=1,ilo(l)
                                DO jlop=1,ilo(lp)
                                   tSUM22(jlop,jlo) = tSUM22(jlop,jlo) + tS22(jlop,jlo)/iso
                                ENDDO
                             ENDDO
                          enddo

                       ENDDO
                    ENDDO

                    wkp = weight(num)
                    sa  = sa  + tsuma  * wkp
                    sb  = sb  + tsumb  * wkp
                    sab = sab + tsumab * wkp
                    sba = sba + tsumba * wkp
                    DO jlo=1,ilo(l)
                       s21(jlo)   = s21(jlo)  + tsum21 (jlo) * wkp
                       se21(jlo)  = se21(jlo) + tsume21(jlo) * wkp
                    ENDDO
                    DO jlop=1,ilo(lp)
                       s12  (jlop) = s12  (jlop) + tsum12 (jlop) * wkp
                       se12 (jlop) = se12 (jlop) + tsume12(jlop) * wkp
                    ENDDO
                    DO jlo=1,ilo(l)
                       DO jlop=1,ilo(lp)
                          s22 (jlop,jlo) = s22 (jlop,jlo) + tsum22(jlop,jlo) * wkp
                       ENDDO
                    ENDDO

                    suma  (num) = tsuma
                    sumb  (num) = tsumb
                    sumab (num) = tsumab
                    sumba (num) = tsumba
                    sum21 (num,:ilo(l))  = tsum21 (:ilo(l))
                    sume21(num,:ilo(l))  = tsume21(:ilo(l))
                    sum12 (num,:ilo(lp)) = tsum12 (:ilo(lp))
                    sume12(num,:ilo(lp)) = tsume12(:ilo(lp))
                    sum22 (num,:ilo(lp),:ilo(l)) = tsum22 (:ilo(lp),:ilo(l))
                 ENDDO
                 !$OMP END PARALLEL DO

                 deallocate( GNT )

                 CALL cputim(time4)
                 CALL walltim(time4_w)
                 time_m=time_m+time4-time3
                 time_m_w=time_m_w+time4_w-time3_w

                 IF(Li.eq.0) then
                    call csplit(nemin,DM_nemaxx,l,jatom,mu,alm,blm,clm,coord)
                 ENDIF
                 CALL cputim(time3)
                 CALL walltim(time3_w)
                 IMAX=JRI(JATOM)

                 DO I=1,IMAX
                    TC_buf(i)=SA*UA(I)+SB*UB(I)+SAB*UAB(I)+SBA*UBA(I)
                 ENDDO
                 DO jlo=1,ilo(l)
                    DO i=1,imax
                       tc_buf(i)=tc_buf(i)+S21(jlo)*U21(I,jlo)+Se21(jlo)*Ue21(I,jlo)
                    ENDDO
                 ENDDO
                 DO jlop=1,ilo(lp)
                    DO i=1,imax
                       tc_buf(i)=tc_buf(i)+S12(jlop)*U12(I,jlop)+Se12(jlop)*Ue12(I,jlop)
                    ENDDO
                 ENDDO
                 DO jlo=1,ilo(l)
                    DO jlop=1,ilo(lp)
                       DO i=1,imax
                          tc_buf(i)=tc_buf(i)+s22(jlop,jlo)*u22(i,jlop,jlo)
                       ENDDO
                    ENDDO
                 ENDDO

                 DO i=1,imax
                    w_RHOLM(I,ILM,jatom)=w_RHOLM(I,ILM,jatom)+TC_buf(i)/MULT(JATOM)
                 ENDDO
                 CALL cputim(time4)
                 CALL walltim(time4_w)
                 time_rad=time_rad+time4-time3
                 time_rad_w=time_rad_w+time4_w-time3_w
              ENDDO lp_sum
           ENDDO l_sum
        ENDDO

        CALL cputim(time2)
        CALL walltim(time2_w)
        time_ilm=time_ilm+time2-time1
        time_ilm_w=time_ilm_w+time2_w-time1_w
     ENDDO
     call psplit(w_xwt1(:,jatom),w_xwteh(:,jatom),w_xwtel(:,jatom),w_xwt1h(:,jatom),w_xwt1l(:,jatom),jatom,nemin,DM_nemaxx,test1,EQBAD,jatombad,lbad)
  ENDDO

  IF(test1.GT.15.d0) THEN
     IF(myrank.eq.master) WRITE(6,1001)  test1,(EQBAD-DM_EF)*Ry2eV, jatombad,lbad,test1/100.
     IF(myrank.eq.master) WRITE(21,1001) test1,(EQBAD-DM_EF)*Ry2eV, jatombad,lbad,test1/100.
  else IF(test1.GT.2.d0) THEN
     IF(myrank.eq.master) WRITE(6,1002)  test1,(EQBAD-DM_EF)*Ry2eV, jatombad,lbad,test1/100.
     IF(myrank.eq.master) WRITE(21,1002) test1,(EQBAD-DM_EF)*Ry2eV, jatombad,lbad,test1/100.
  ENDIF

  DEALLOCATE( aalm, bblm, cclm )
  DEALLOCATE(alm,blm,clm)
  DEALLOCATE(dh_alm,dh_blm,dh_clm)

1001 FORMAT(//,'   QTL-B VALUE .EQ. ',F10.5,' in Band of energy ',F9.4,'eV from EF ATOM=',i5,2x,'L=',i3,/,'    Check for ghostbands or EIGENVALUES BELOW XX messages',/, &
              '    The projection of charge to \dot{u}(r) is',F10.5,', which is large. Adjust your Energy-parameters for this ATOM and L (or use -in1new switch), check RMTs  !!!',//)
1002 FORMAT(//,'   QTL-B VALUE .EQ. ',F10.5,' in Band of energy ',F9.4,'eV from EF ATOM=',i5,2x,'L=',i3,/, &
               '   The projection of charge to \dot{u}(r) is',F10.5,', which is large. Most likely no ghostbands, but adjust Energy-parameters for this ATOM and L',//)

END SUBROUTINE cmp_MT_density


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!       NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!BOP
! !ROUTINE: ods_dconv
!
! !INTERFACE:
!
      subroutine ods_dconv ( var, cdiagbuf, data, ninfo, nobs,
     .                       ods, station, weight, mobs, kobs, iks, ioff, rc )

      use m_odsmeta
      use m_ods
      use m_ods_obsdiags, only : ods_obsdiags
      use m_ods_obsdiags, only : ods_obsdiags_getparam
      use m_fpe, only: isInf

      implicit NONE

! !INPUT PARAMETERS:

      integer,          intent(in)    :: mobs
      integer,          intent(in)    :: ninfo, nobs, ioff
      real(4),          intent(in)    :: data(ninfo,nobs)
      character(len=*), intent(in)    :: var

! !INPUT/OUTPUT PARAMETERS:

      integer,          intent(inout) :: kobs, iks
      character(len=*), intent(inout) :: cdiagbuf(nobs)
      type(ods_vect),   intent(inout) :: ods
      real(4),          intent(inout) :: weight(mobs)
      character(len=*), intent(inout) :: station(mobs)

! !OUTPUT PARAMETERS:

      integer,          intent(out)   :: rc

! !DESCRIPTION: Converts conventional data from GSI diag_ files to ODS.
!
! !REVISION HISTORY:
!	19Apr2004 - R. Todling - Initial code.
!       03Dec2004 - D. Dee     - remove kx conversion; various corrections;
!                                pass fractional weight
!       16Mar2005 - Meta       - Added sst
!       25May2005 - D. Dee     - Changed qcx values
!       07Nov2005 - Todling    - Updated to handle PW
!       24Jan2006 - Todling    - Bug fix; defining xvec w/ undef's
!       31Jan2006 - Todling    - Added check on varQC
!       24Feb2006 - Steve B, Meta - Modify 'ps' due to change in diag file.
!        8Mar2006 - Meta       - undo xvec undef, modify check on obs error
!       15Mar2006 - Meta        isNaN check on 'sst' sigO work around beta6's
!                                bug in SST diag file write
!       30Oct2006 - Meta       - added 'muse' to diag output, use (if
!                                  available) to determine passive obs
!       14Dec2006 - Todling    - update to work w/ GSI-2006_09;
!                                Note: obs slot keeps bias corrected obs
!       19Dec2007 - Todling    - Add ability to read in observation impacts
!       17Feb2009 - Todling    - Add handle to store sensitivies rather than impacts
!       17Mar2009 - Meunier    - Add handle for Lagragian-type observations
!       05Apr2009 - Todling    - Add GPS refractivity and bending angle
!       29Jan2010 - Meta       - modified GPS (o-f) for change in diag file in Jun2009 GSI
!       01Apr2010 - McCarty/RT - add doppler wind lidar
!       26Jul2010 - Todling    - add tropical cycle knob
!       14Feb2012 - Todling    - idia from 19 to 20 (per GSI update)
!       28Jun2012 - Meta       - screen gpsbnd OmF for invalid values
!        2Aug2012 - Meta       - identify drifting buoy from subtype & stn ID
!        4Sep2012 - Meta       - switch gpsbnd test to use m_fpe isInf
!       17May2013 - Meta       - write temperature bias correction to xm slot
!       25Jun2013 - Todling    - upd idia(t)=20 after addition of phase-of-flight
!                                   to temperature diags
!       21Jan2014 - Todling    - option to choose type of sigo to go into ODS file
!       28Jan2014 - Todling    - use sensitivity slot (idia) from header
!       18Mar2015 - Meta       - fill in 'lev' value for pres=0.0 from GPS
!
!EOP
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

      character(len=*), parameter :: myname = 'ods_dconv'

      integer, parameter   :: r_single = selected_real_kind(6)
      real(r_single)  zero_single,tiny_single
      real small_num, nlomx(2), tlomx(2), obimp(2)
      logical :: lobsdiagsave, passed, lobssens, ladjsigo

      integer i, iu, iv, kobs0, idia, ilat, ilon, ios, iwmo, n311, isigo_slot

      real, parameter :: undef = 1.e15

!     Pointers to ods attributes:
!     --------------------------
      integer, pointer :: kt(:)       ! data type index
      integer, pointer :: kx(:)       ! data source index
      integer, pointer :: ks(:)       ! sounding index
      real   , pointer :: lon(:)      ! longitude of obs (degrees)
      real   , pointer :: lat(:)      ! latitude of obs (degrees)
      real   , pointer :: lev(:)      ! pressure level of obs (hPa)
      integer, pointer :: time(:)     ! time
      real   , pointer :: obs(:)      ! observation
      real   , pointer :: OmF(:)      ! obs-minus-fcst (O-F)
      real   , pointer :: OmA(:)      ! obs-minus-ana  (O-A)
      real   , pointer :: sigo(:)     ! obs error std dev
      real   , pointer :: xm(:)       ! metadata
      integer, pointer :: qcx(:)      ! exclusion mark
      integer, pointer :: qch(:)      ! history mark

!     Assign pointers to ODS attributes
!     ---------------------------------
      kt   => ods%data%kt
      kx   => ods%data%kx
      ks   => ods%data%ks
      lon  => ods%data%lon
      lat  => ods%data%lat
      lev  => ods%data%lev
      time => ods%data%time
      obs  => ods%data%obs
      OmF  => ods%data%OmF
      OmA  => ods%data%OmA
      sigo => ods%data%Xvec
      xm   => ods%data%xm
      qcx  => ods%data%qcexcl
      qch  => ods%data%qchist

      tiny_single = tiny(zero_single)
      small_num = 1.e3 * tiny_single

      rc = 0  ! all is well to start with

      call ods_obsdiags_getparam ( 'lobsdiagsave', lobsdiagsave )
      call ods_obsdiags_getparam ( 'lobssens', lobssens )
      call ods_obsdiags_getparam ( 'ladjsigo', ladjsigo )

      if ( ladjsigo ) then
          isigo_slot=16 ! GSI-adjusted ob error
      else
          isigo_slot=14 ! prepbufr (prescribed) ob error
      endif

      kobs0 = kobs
      select case (var)

      case (' dw')  ! doppler wind lidar

          do i = 1, nobs

	      kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktdw
              kx(kobs)     = nint(data(1,i))

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = data(6,i)
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              omf(kobs)    = data(18,i)           ! omf used in the analysis
              oma(kobs)    = undef
              xm(kobs)     = obs(kobs)-omf(kobs)+data(19,i) ! original obs w/o bias correction

	      qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) <  0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

	      if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(isigo_slot,i) ! sigo used in analysis
                 if(data(13,i)<1.and.qcx(kobs)==0) qcx(kobs) = X_NCEP_NLNQC
	      else                                ! rejected by QC
	         sigo(kobs) = undef
		 qcx(kobs) = 2
	      endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
	      weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                  endif
              endif

          end do

      case (' ps')  ! surface pressure
                    ! Note: It is really ln(ps) that is analyzed

          do i = 1, nobs

	      kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, 'dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktps2m               ! surface pressure
              kx(kobs)     = nint(data(1,i))

              if (kx(kobs) == 180 .and. nint(data(2,i)) == 562) then
                 read(cdiagbuf(i),*,iostat=ios) iwmo
                 if (ios == 0 .and. iwmo > 0) then
                    if (mod(iwmo,1000) >=500) then
                       kx(kobs) = 199
                    end if
                 end if
              end if

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = undef
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              omf(kobs)    = data(18,i)           ! omf used in analysis
              oma(kobs)    = undef                ! no info available
              xm(kobs)     = data(7,i)            ! surface height

              qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) < 0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

	      if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(isigo_slot,i) ! sigo (hPa)
                 if(data(13,i)<1.and.qcx(kobs)==0) qcx(kobs) = X_NCEP_NLNQC
	      else                                ! rejected by QC
	         sigo(kobs) = undef
		 qcx(kobs) = 2
	      endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
	      weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                  endif
              endif

          end do

      case ('tcp')  ! tropical cyclone simulated surface pressure

          do i = 1, nobs

	      kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, 'dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktps2m               ! surface pressure
              kx(kobs)     = nint(data(1,i))

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = undef
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              omf(kobs)    = data(18,i)           ! omf used in analysis
              oma(kobs)    = undef                ! no info available
              xm(kobs)     = data(7,i)            ! surface height

              qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) < 0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

	      if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(isigo_slot,i) ! sigo (hPa)
                 if(data(13,i)<1.and.qcx(kobs)==0) qcx(kobs) = X_NCEP_NLNQC
	      else                                ! rejected by QC
	         sigo(kobs) = undef
		 qcx(kobs) = 2
	      endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
	      weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                  endif
              endif

          end do

      case ('  q')  ! specific humidity
                    ! Note: it is really pseudo-rh that is analyzed

          do i = 1, nobs

	      kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, 'dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktqq                 ! specific humidity
              kx(kobs)     = nint(data(1,i))

              if (kx(kobs) == 180 .and. nint(data(2,i)) == 562) then
                 read(cdiagbuf(i),*,iostat=ios) iwmo
                 if (ios == 0 .and. iwmo > 0) then
                    if (mod(iwmo,1000) >=500) then
                       kx(kobs) = 199
                    end if
                 end if
              end if

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = data(6,i)
              time(kobs)   = data(8,i) * 60       ! convert to minutes from ana time
              obs(kobs)    = 1e3*data(17,i)       ! observation
              omf(kobs)    = 1e3*data(18,i)       ! omf used in analysis [g/kg]
              oma(kobs)    = undef                ! no info available
              xm(kobs)     = 1e3*data(20,i)       ! guess saturated mixing ratio [g/kg]

	      qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) < 0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

	      if (data(16,i)>small_num) then
                 sigo(kobs) = 1e3/data(isigo_slot,i) ! actual sigo used in analysis (for sp hum, in g/kg)
                 if(data(13,i)<1.and.qcx(kobs)==0) qcx(kobs) = X_NCEP_NLNQC
	      else                                ! rejected by QC
	         sigo(kobs) = undef
		 qcx(kobs) = 2
	      endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
	      weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                     if(lobssens) sigo(kobs)=sigo(kobs)*1.e-3 ! convert to 1/[g/kg]
                  endif
              endif

          end do

      case ('spd')  ! wind speed

          do i = 1, nobs

	      kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktus10               ! define it as 10m speeds
              kx(kobs)     = nint(data(1,i))

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = undef
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              omf(kobs)    = data(18,i)           ! omf used in analysis
              oma(kobs)    = undef                ! no info available
              xm(kobs)     = data(7,i)            ! elevation

	      qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) <  0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

	      if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(isigo_slot,i) ! sigo used in analysis
                 if(data(13,i)<1.and.qcx(kobs)==0) qcx(kobs) = X_NCEP_NLNQC
	      else                                ! rejected by QC
	         sigo(kobs) = undef
		 qcx(kobs) = 2
	      endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
	      weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                  endif
              endif

          end do

      case ('  t')  ! virtual temperature

	  n311=0
          do i = 1, nobs

	      kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktTv
              kx(kobs)     = nint(data(1,i))

              if (kx(kobs) == 180 .and. nint(data(2,i)) == 562) then
                 read(cdiagbuf(i),*,iostat=ios) iwmo
                 if (ios == 0 .and. iwmo > 0) then
                    if (mod(iwmo,1000) >=500) then
                       kx(kobs) = 199
                    end if
                 end if
	      elseif(kx(kobs)==311) then
	         n311=n311+1
	         kx(kobs)=304		! a fix/hack for MLS temperature
              end if

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = data(6,i)
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              omf(kobs)    = data(18,i)           ! omf used in the analysis
              oma(kobs)    = undef
              xm(kobs)     = data(19,i) - data(18,i) ! omgnbc - omgbc

	      qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) <  0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

	      if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(isigo_slot,i) ! sigo used in analysis
                 if(data(13,i)<1.and.qcx(kobs)==0) qcx(kobs) = X_NCEP_NLNQC
	      else                                ! rejected by QC
	         sigo(kobs) = undef
		 qcx(kobs) = 2
	      endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
	      weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                  endif
              endif

!	if(kx(kobs)==304) then
!	  write(*,'(i2,i3,i5,i6,i5,3(1x,f8.3),1x,i3,6(1x,e8.3e1))') qcx(kobs),i,kobs,kx(kobs),kt(kobs),
!     &		lat(kobs),lon(kobs),lev(kobs),time(kobs),obs(kobs),omf(kobs),oma(kobs),sigo(kobs)
!	endif
          end do
	  write(*,*) 'n311 =',n311

      case (' uv')  ! vector wind

          do i = 1, nobs

	     kobs = kobs + 1
             if(kobs>mobs) then
                rc = 99
                print *, myname, ' dim violation, var = ', var
                exit
             endif
             iu   = kobs
	     kobs = kobs + 1
             if(kobs>mobs) then
                rc = 99
                print *, myname, ' dim violation, var = ', var
                exit
             endif
             iv   = kobs

             kt(iu)     = ktuu
             kx(iu)     = nint(data(1,i))
             lat(iu)    = data(3,i)
             lon(iu)    = data(4,i)
             lev(iu)    = data(6,i)
             time(iu)   = data(8,i) * 60         ! minutes from ana time
             obs(iu)    = data(17,i)             ! observation
             omf(iu)    = data(18,i)             ! omf used in analysis
             oma(iu)    = undef
             xm(iu)     = data(7,i)              ! elevation

	     qch(iu)    = 0                      ! no info available
             qcx(iu)    = 0

             ks(iu)     = iks
             station(iu)= cdiagbuf(i)
	     weight(iu) = data(13,i)             ! fractional weight

             kt(iv)     = ktvv
             kx(iv)     = nint(data(1,i))
             lat(iv)    = data(3,i)
             lon(iv)    = data(4,i)
             lev(iv)    = data(6,i)
             time(iv)   = data(8,i) * 60         ! minutes from ana time
             obs(iv)    = data(20,i)             ! observation
             omf(iv)    = data(21,i)             ! omf used in analysis
             oma(iv)    = undef
             xm(iv)     = data(7,i)              ! elevation

	     qch(iv)    = 0                      ! no info available
             qcx(iv)    = 0

             ks(iv)     = iks
             station(iv)= cdiagbuf(i)
	     weight(iv) = data(13,i)             ! fractional weight

             if (kx(iu) == 280 .and. nint(data(2,i)) == 562) then
                read(cdiagbuf(i),*,iostat=ios) iwmo
                if (ios == 0 .and. iwmo > 0) then
                   if (mod(iwmo,1000) >=500) then
                      kx(iu) = 299
                      kx(iv) = 299
                   end if
                end if
             end if

             if (ninfo >= 12) then
                if (data(12,i) <  0. ) then
                   qcx(iu) = X_PASSIVE
                   qcx(iv) = X_PASSIVE
                endif
             endif
	     if (data(16,i)>small_num) then
                sigo(iu) = 1.0/data(isigo_slot,i) ! sigo
                sigo(iv) = 1.0/data(isigo_slot,i) ! sigo
                 if(data(13,i)<1.and.qcx(iu)==0.and.qcx(iv)==0) then
                    qcx(iu) = X_NCEP_NLNQC
                    qcx(iv) = X_NCEP_NLNQC
                 endif
	     else                                ! rejected by QC
	        sigo(iu) = undef
	        sigo(iv) = undef
	        qcx(iu)  = 2
	        qcx(iv)  = 2
	     endif

              if (lobsdiagsave) then
                  idia  = ioff
                  obimp = 0.0
                  sigo(iu) = 0.0
                  sigo(iv) = 0.0
                  call ods_obsdiags ( nlomx, tlomx, obimp, data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                    sigo(iu) = obimp(1)             ! place obs sensitivity in sigo slot
                    sigo(iv) = obimp(2)             ! place obs sensitivity in sigo slot
                    qcx (iu) = 0                    ! overwrite qc flag
                    qcx (iv) = 0                    ! overwrite qc flag
                  endif
              endif

           end do

      case ('sst')     ! sea surface temperature

          do i = 1, nobs

	      kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktSST
              kx(kobs)     = nint(data(1,i))

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = undef
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              omf(kobs)    = data(18,i)           ! omf used in analysis
              oma(kobs)    = undef
              xm(kobs)     = data(5,i)            ! station elevation

	      qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) <  0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

	      if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(isigo_slot,i) ! sigo used in analysis
                 if(data(13,i)<1.and.qcx(kobs)==0) qcx(kobs) = X_NCEP_NLNQC
	      else                                ! rejected by QC
	         sigo(kobs) = undef
		 qcx(kobs) = 2
	      endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
	      weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                  endif
              endif

          end do

      case (' pw')     ! total column water

          do i = 1, nobs

              kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              kt(kobs)     = ktTPW
              kx(kobs)     = nint(data(1,i))

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = data(6,i)            ! observation pressure
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              omf(kobs)    = data(18,i)           ! omf use in analysis
              oma(kobs)    = undef
              xm(kobs)     = data(9,i)            ! input (prepbufr) qc mark

              qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (ninfo >= 12) then
                 if (data(12,i) <  0. ) then
                    qcx(kobs) = X_PASSIVE
                 endif
              endif

              if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(isigo_slot,i) ! sigo
              else                                ! rejected by QC
                 sigo(kobs) = undef
                 qcx(kobs) = 2
              endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
              weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp = 0.0
                  sigo(kobs) = 0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if(passed) then
                     sigo(kobs) = obimp(1)
                     qcx (kobs) = 0
                  endif
              endif

          end do

      case ('lag')

          do i = 1, nobs

              kobs = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              ilat = kobs
              kobs = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              ilon = kobs

!             Take lat observation first
!             --------------------------
              kt(ilat)     = ktlat
              kx(ilat)     = nint(data(1,i))
              station(ilat)= cdiagbuf(i)

              lon(ilat)    = data(4,i)
              lat(ilat)    = data(5,i)
              lev(ilat)    = data(6,i)
              time(ilat)   = data(7,i) * 60 ! convert to minutes from ana time
              obs(ilat)    = data(5,i)      ! obs
              omf(ilat)    = data(17,i)     ! omf
              oma(ilat)    = undef   ! no info available
              xm(ilat)     = undef

              qch(ilat)    = 0       ! no info available
              qcx(ilat)    = 0

              if (data(8,i) < 0.) then
                 qcx(ilat) = X_PASSIVE
              endif

              if ( qcx(ilat) == 0 ) then
                 sigo(ilat) = 1./data(12,i)                ! sigo
              else                                         ! rejected by QC
                 sigo(ilat) = undef
                 qcx(ilat)  = 2
              endif

              ks(ilat)     = nint(data(3,i))   ! balloon identifier

!             Take lon observation next
!             -------------------------
              kt(ilon)     = ktlon
              kx(ilon)     = nint(data(1,i))
              station(ilon)= cdiagbuf(i)

              lon(ilon)    = data(4,i)
              lat(ilon)    = data(5,i)
              lev(ilon)    = data(6,i)
              time(ilon)   = data(7,i) * 60 ! convert to minutes from ana time
              obs(ilon)    = data(4,i)      ! obs
              omf(ilon)    = data(16,i)     ! omf
              oma(ilon)    = undef   ! no info available
              xm(ilon)     = undef

              qch(ilon)    = 0       ! no info available
              qcx(ilon)    = 0

              if (data(8,i) < 0.) then
                 qcx(ilon) = X_PASSIVE
              endif

              if ( qcx(ilon) == 0 ) then
                 sigo(ilon) = 1./data(11,i)                ! sigo
              else                                         ! rejected by QC
                 sigo(ilon) = undef
                 qcx(ilon) = 2
              endif

              ks(ilon)     = nint(data(3,i))   ! balloon identifier

!   OBSERVATION SENSITIVIES NOT HANDLED YET

          end do

      case ('gps')     ! GPS refractivity and bending angle (KX should tell)

          do i = 1, nobs

              kobs         = kobs + 1
              if(kobs>mobs) then
                 rc = 99
                 print *, myname, ' dim violation, var = ', var
                 exit
              endif
              if(nint(data(20,i))==0)then
                 kt(kobs)  = ktGPSr    ! refractivity
                 xm(kobs)  = data(9,i) ! height above model terrain
              else
                 kt(kobs)  = ktGPSb    ! bending angle
                 xm(kobs)  = data(7,i) ! impact height in meters
              endif
              kx(kobs)     = nint(data(1,i))

              lat(kobs)    = data(3,i)
              lon(kobs)    = data(4,i)
              lev(kobs)    = data(6,i)            ! observation pressure
              time(kobs)   = data(8,i) * 60       ! minutes from ana time
              obs(kobs)    = data(17,i)           ! observation
              if (isInf(data(5,i))) then
                 omf(kobs) = undef                ! skip problem GPS OmF
              else
                 omf(kobs) = data(17,i)*data(5,i) ! omf use in analysis
              endif

              oma(kobs)    = undef

              qch(kobs)    = 0                    ! no info available
              qcx(kobs)    = 0

              if (data(6,i) == 0.0) then           ! fix for pressure = 0.
                 if (data(19,i) < 1.) then
                    lev(kobs) = 1050.             ! obs below model sfc
                 else
                    lev(kobs) = 0.01              ! obs above model top
                 endif
              endif

              if (data(12,i) <  0. ) then
                 qcx(kobs) = X_PASSIVE
              endif

              if (data(16,i)>small_num) then
                 sigo(kobs) = 1.0/data(16,i)      ! sigo
              else                                ! rejected by QC
                 sigo(kobs) = undef
                 qcx(kobs) = 2
              endif

              ks(kobs)     = iks
              station(kobs)= cdiagbuf(i)
              weight(kobs) = data(13,i)           ! fractional weight

              if (lobsdiagsave) then              ! place obs sensitivity in sigo slot
                  idia  = ioff
                  obimp(1) = 0.0
                  sigo(kobs)=0.0
                  call ods_obsdiags ( nlomx(1), tlomx(1), obimp(1), data, idia, i, ninfo, nobs, undef, passed )
                  if (passed) then
                    sigo(kobs)=obimp(1)
                    qcx(kobs)=0
                  endif
              endif

          end do

      case default  ! everything else

           print *, myname, ' can''t handle var = ', var, nobs, ' observations.'
	   rc = 98

      end select

!     Nullify pointers
!     -----------------
      if(associated(lat)   ) nullify(lat)
      if(associated(lon)   ) nullify(lon)
      if(associated(lev)   ) nullify(lev)
      if(associated(time)  ) nullify(time)
      if(associated(kt)    ) nullify(kt)
      if(associated(kx)    ) nullify(kx)
      if(associated(ks)    ) nullify(ks)
      if(associated(xm)    ) nullify(xm)
      if(associated(qch)   ) nullify(qch)
      if(associated(qcx)   ) nullify(qcx)
      if(associated(obs)   ) nullify(obs)
      if(associated(omf)   ) nullify(omf)
      if(associated(oma)   ) nullify(oma)
      if(associated(sigo)  ) nullify(sigo)

      end subroutine ods_dconv