      subroutine satfill1(csat_id,csat_type,
     &               i4time_data_in,smsng,
     &               c_type,
     &               n_lines,n_elems,
     &               cdirpath,
     &               r_missing_data,
     &               image_main,
     &               percent_missing,
     &               istatus)
c
c
c
      implicit none
c
      include 'netcdf.inc'

      integer   n_lines
      integer   n_elems
      integer   i,n,j,nt
      integer   record

      REAL      la1
      REAL      lo1
      REAL      dx,dy
      REAL      latin
      REAL      lov
      INTEGER   validTime
      Integer   nx2,ny2
      integer   rcode,ncid

      character*13  cfname13
      character*13  cvt_i4time_wfo_fname13
      character*9   cfname
      character*3   csat_type
      character*3   c_type
      character*6   csat_id
      character*200 cdirpath
      character*200 c_filename
      character*255 pathname

      real    image_main(n_elems,n_lines)
      real    image_prev(n_elems,n_lines)
      real    latitude(n_elems,n_lines)
      real    longitude(n_elems,n_lines)
      real    r_missing_data
      real    percent_missing
      real    smsng
      real    scale_img

      integer bcnt
      integer itot
      integer istatus
      integer lstatus
      integer io_status
      integer iqstatus
      integer i4time_data_in
      integer i4time_needed_in
      integer i4time_nearest
c
c -------------------------------------------------------
c
      istatus = 1

      nt=index(c_type,' ')-1
      if(nt.le.0)nt=3

      bcnt=0
      itot=n_lines*n_elems
      do j = 1,n_lines
         do i = 1,n_elems
            if(image_main(i,j).eq.r_missing_data)then
               bcnt=bcnt+1
            endif
         enddo
      enddo

      percent_missing=float(bcnt)/float(itot)
c
c if any bad/missing data points found then acquire image from
c 15 minutes previous
c
      write(6,*)'    Num of msng pix in satfill (current image): ',bcnt
      write(6,*)'    percent missing: ',percent_missing
c
c only try to fill current image with pixels from previous (no more than 15 min)
c image if less than 25% of current image is bad.
c
      if(percent_missing.gt.0.0.and.percent_missing.le.0.25)then

         i4time_needed_in=i4time_data_in-900
         n=index(cdirpath,' ')

         if(csat_type.eq.'wfo')then
            cfname13 = cvt_i4time_wfo_fname13(i4time_needed_in)
            pathname=cdirpath(1:n-1)//cfname13(1:11)//'*'
         else
            call make_fnam_lp(i4time_needed_in,cfname,lstatus)
          pathname=cdirpath(1:n-1)//cfname(1:8)//'*_'//c_type(1:nt)
         endif

         call get_file_time(pathname
     1          ,i4time_needed_in,i4time_nearest)

         if(abs(i4time_needed_in-i4time_nearest).le.181)then
            write(*,*)'    Found file for qc fill'
            if(csat_type.eq.'wfo')then
               cfname13=cvt_i4time_wfo_fname13(i4time_nearest)
               c_filename=cdirpath(1:n-1)//cfname13
            else
               call make_fnam_lp(i4time_nearest,cfname,lstatus)
               c_filename=cdirpath(1:n-1)//cfname//'_'//c_type(1:nt)
               rcode=NF_OPEN(c_filename,NF_NOWRITE,NCID)
               if(rcode.ne.nf_noerr) return
               call get_cdf_dims(ncid,record,nx2,ny2,istatus)
               record=1
               if(istatus.eq.1)then
                  print*,'Error reading cdf dimensions'
                  return
               endif

            endif
            n=index(c_filename,' ')
            write(6,*)'    Filename: ',c_filename(1:n-1)

            call readcdf(csat_id,csat_type,c_type,
!    &                   nx2,ny2,
     &                   record,
     &                   n_elems,n_lines,
     &                   image_prev,scale_img,
     &                   latitude,
     &                   longitude,
     &                   la1,lo1,
     &                   Dx,Dy,
     &                   Latin,Lov,
     &                   validTime,
     &                   ncid,
     &                   io_status)
            if(io_status .ne. 1)then
               write(6,*)'    Error getting image for qc'
               write(6,*)'    Filename: ',c_filename(1:n-1)
               goto 998
            endif
c
c The missing data flag is r_missing_data!
c First examine the previous image for missing data.
c Get missing satellite data value.
c
            call  set_missing_sat(csat_id,csat_type,c_type,
     &               image_prev,n_elems,n_lines,
     &               smsng,r_missing_data,
     &               istatus)
            if(istatus .lt. 0)then
               write(6,*)'    Found missing data in set_missing_sat'
               write(6,*)'    Num of msng pix in prev img',abs(istatus)
               goto 998
            else
               write(6,*)'    No missing pixels in previous image'
               write(6,*)'    using previous image in image_compare'
            endif
c
c use following subroutine to compare the main and previous images
c for qcfill.
c
            call image_compare(n_lines,n_elems,r_missing_data,
     &                         image_main,image_prev,
     &                         iqstatus)

            if(iqstatus.gt.0)then
               write(6,*)'    Sat pixels filled in image_compare'
               write(6,*)'    = ',iqstatus
               write(6,*)'    recompute percent_missing'
c
c recompute the percent missing
c
               bcnt=0
               itot=0
               do j = 1,n_lines
               do i = 1,n_elems
                  itot=itot + 1
                  if(image_main(i,j).eq.r_missing_data)then
                     bcnt=bcnt+1
                  endif
               enddo
               enddo

               percent_missing=float(bcnt)/float(itot)

            elseif(iqstatus.lt.0)then
               write(6,*)'    Error filling points in image_compare'
               goto 1000
            else
               write(6,*)'    No pixels filled in image_compare'
            endif

         else

            write(6,*)'    No previous image exist for fill routine'

         endif

      elseif(percent_missing.ge.0.25)then

         write(6,*)'    More than 25% of current image missing!'
         write(6,*)'    ***************************************'

      else

         write(6,*)'    No filling required for image_main'

      endif

      goto 1000

998   write(6,*)'Not using prev image to fill'

1000  return
      end


MODULE module_kma2netcdf_interface

   use module_kma_wave2grid

   USE module_domain
   USE module_timing
   USE module_driver_constants
   USE module_configure
   use module_kma_wave2grid
   USE module_tiles
!  implicit none    !shc-wei

CONTAINS

SUBROUTINE kma2netcdf_interface ( grid, config_flags)

!  IMPLICIT NONE    !shc-wei

!--Input data.
   TYPE (grid_config_rec_type)   :: config_flags
   TYPE(domain), TARGET          :: grid
#ifdef DEREF_KLUDGE
   INTEGER     :: sm31 , em31 , sm32 , em32 , sm33 , em33

   sm31             = grid%sm31
   em31             = grid%em31
   sm32             = grid%sm32
   em32             = grid%em32
   sm33             = grid%sm33
   em33             = grid%em33
#endif

   call kma2netcdf_solver( grid, config_flags  &

#include "actual_args.inc"

               )

end SUBROUTINE kma2netcdf_interface

SUBROUTINE kma2netcdf_solver( grid, config_flags &
#include "dummy_args.inc"
                 )

!  IMPLICIT NONE   !shc-wei

!--Input data.
   TYPE (grid_config_rec_type)   :: config_flags
   TYPE(domain), TARGET               :: grid
!  Definitions of dummy arguments to solve

#include "dummy_decl.inc"
!    INCLUDE 'mpif.h'
    real, allocatable      :: q(:,:,:)
    Integer                :: my_proc_id, ierr
    Integer                :: ii, jj,landmask_T213(428,215)
    real                   :: sfc_T213(428,215)
!---------------------------------------------------------------------------
   INTEGER  :: ids,ide, jds,jde, kds,kde   ! domain dims.
   INTEGER  :: ims,ime, jms,jme, kms,kme   ! memory dims.
   INTEGER  :: ips,ipe, jps,jpe, kps,kpe   ! patch  dims.
   INTEGER  :: its,ite, jts,jte, kts,kte   ! Tile   dims.
   INTEGER  :: i
   INTEGER  :: IGRD, JGRD, KGRD, JCAP, KMAX, INTVL
!rizvi add ------------------------------------------------------------------
   NAMELIST /kma2netcdf_parm/ IGRD, JGRD, KGRD, JCAP, KMAX, INTVL
!
      READ  (111, NML = kma2netcdf_parm, ERR = 8000)
      close (111)
      write(unit=*, fmt='(A,5(1x,/,5x,A,i6))')'kma2netcdf_parm namelist read: ',&
      'IGRD= ',IGRD,'JGRD= ',JGRD,'KGRD= ',KGRD,'JCAP = ',JCAP,'KMAX= ',KMAX,'INTVL= ',INTVL
      DPHI=180./(JGRD-1)
      LMAX=KGRD-1
      KLMAX=KMAX
      MEND1 = JCAP + 1
      NEND1 = JCAP + 1
      JEND1 = JCAP + 1
      IMAXG = IGRD
      JMAXG = JGRD - 1

      IMAX  =360./DPHI+0.5
      IOUT  =IMAX/INTVL
      JMAX  =180./DPHI+1.5
      JOUT  =(JMAX-1)/INTVL+1
      IMX   =IMAX+2
      JOUTHF= (JOUT+1)/2
      JMXGHF= (1+JMAXG)/2
      KMX2  =KMAX*2
      LMX2 =LMAX*2
      MNWAV =MEND1*(MEND1+1)/2

!rizvi add ------------------------------------------------------------------
   CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )

  call copy_dims( grid, xp, &
                   ids, ide, jds, jde, kds, kde, &
                   ims, ime, jms, jme, kms, kme, &
                   ips, ipe, jps, jpe, kps, kpe  )
!--Compute these starting and stopping locations for each tile and number of tiles.

   CALL set_tiles ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe )

   call copy_tile_dims( grid, xp, its, ite, jts, jte, kts, kte )

   allocate (q(ims:ime,jms:jme,kms:kme))

!   go to   100
#ifndef DEREF_KLUDGE
     call W2GCONV(IGRD, JGRD, KGRD, JCAP, KMAX, INTVL , &
             DPHI, LMAX, KLMAX, MEND1, NEND1, JEND1, IMAXG, JMAXG, &
             IMAX, IOUT, JMAX, JOUT, IMX, JOUTHF, JMXGHF, KMX2, LMX2, MNWAV, &
             ht, psfc, t_2, u_2, v_2, q, KMA_A, KMA_B, &
             xp%ims, xp%jms, xp%kms, xp%ime, xp%jme, xp%kme,&
             xp%ids, xp%jds, xp%kds, xp%ide, xp%jde, xp%kde,&
             xp%its, xp%jts, xp%kts, xp%ite, xp%jte, xp%kte )
#else
     call W2GCONV(IGRD, JGRD, KGRD, JCAP, KMAX, INTVL , &
             DPHI, LMAX, KLMAX, MEND1, NEND1, JEND1, IMAXG, JMAXG, &
             IMAX, IOUT, JMAX, JOUT, IMX, JOUTHF, JMXGHF, KMX2, LMX2, MNWAV, &
     ht(ims,jms),psfc(ims,jms),t_2(ims,jms,kms),&
     u_2(ims,jms,kms), v_2(ims,jms,kms), q(ims,jms,kms),&
     KMA_A(kms),KMA_B(kms), ims, jms, kms, ime, jme, kme, &
                            ids, jds, kds, ide, jde, kde, &
                            its, jts, kts, ite, jte, kte  )
#endif

!  convert KMA pressure which is in hPa into Psacal in grid-array
    psfc(its:ite,jts:jte) = 100. * psfc(its:ite,jts:jte)
100  continue
 my_proc_id = 0
#ifdef DM_PARALLEL
   call MPI_COMM_RANK( MPI_COMM_WORLD, my_proc_id, ierr )
#else
   my_proc_id = 0
#endif

   moist(ims:ime,jms:jme,kms:kme,P_qv) = q(ims:ime,jms:jme,kms:kme)
   deallocate (q)
! Load landmask from KMA-original land mask for T213
    if( JCAP == 213 ) then
     open( UNIT = 151, file= 'KMA_landmask_428_215', status= 'old')
       do jj=jds,jde
        read(151,'(428i1)', err=9000) (landmask_T213(ii,jj),ii=1,428)
       enddo
       do jj=jts,jte
        landmask(its:ite,jj) = landmask_T213(its:ite,jde-jj+1)
       enddo
       write(unit=*, fmt='(A)')'read successfully landmask'
       close (151)
! Load U10 at T213 (428x215) resolution
     open( UNIT = 151, file= 'nwpgr_UUUU.2007020100', status= 'old')
        read(151,'(10e20.10)', err=9000) sfc_T213
       do jj=jts,jte
        u10(its:ite,jj) = sfc_T213(its:ite,jde-jj+1)
       enddo
       write(unit=*, fmt='(A)')'read successfully U10'
       close (151)
! Load V10 at T213 (428x215) resolution
     open( UNIT = 151, file= 'nwpgr_VVVV.2007020100', status= 'old')
        read(151,'(10e20.10)', err=9000) sfc_T213
       do jj=jts,jte
        v10(its:ite,jj) = sfc_T213(its:ite,jde-jj+1)
       enddo
       write(unit=*, fmt='(A)')'read successfully V10'
       close (151)
! Load T2  at T213 (428x215) resolution
     open( UNIT = 151, file= 'nwpgr_TTTT.2007020100', status= 'old')
        read(151,'(10e20.10)', err=9000) sfc_T213
       do jj=jts,jte
         t2(its:ite,jj) = sfc_T213(its:ite,jde-jj+1)
       enddo
       write(unit=*, fmt='(A)')'read successfully T2'
       close (151)
! Load Q2  at T213 (428x215) resolution
     open( UNIT = 151, file= 'nwpgr_QQQQ.2007020100', status= 'old')
        read(151,'(10e20.10)', err=9000) sfc_T213
       do jj=jts,jte
         q2(its:ite,jj) = sfc_T213(its:ite,jde-jj+1)
       enddo
       write(unit=*, fmt='(A)')'read successfully Q2'
       close (151)
! Load SST at T213 (428x215) resolution
     open( UNIT = 151, file= 'nwpgr_SSTT.2007020100', status= 'old')
        read(151,'(10e20.10)', err=9000) sfc_T213
       do jj=jts,jte
         sst(its:ite,jj) = sfc_T213(its:ite,jde-jj+1)
       enddo
       write(unit=*, fmt='(A)')'read successfully SST'
       close (151)

    else
    write(unit=*, fmt='(A,i3)')'Surface data is not available for T',JCAP
    endif

    write(unit=*, fmt='(A)')'Job done for kma2netcdf_solver'
    return
8000 write(unit=*, fmt='(A)')'read error on namelist unit 111'
     stop
9000 write(unit=*, fmt='(A)')'read error on unit 151'
     stop
END SUBROUTINE kma2netcdf_solver

SUBROUTINE copy_dims(grid, xp, &
                     ids, ide, jds, jde, kds, kde, &
                     ims, ime, jms, jme, kms, kme, &
                     ips, ipe, jps, jpe, kps, kpe )
!------------------------------------------------------------------------------
!  PURPOSE: Copy dimensioning information from grid structure.
!
!------------------------------------------------------------------------------

   USE module_domain
   TYPE(domain), INTENT(IN)         :: grid
   TYPE (xpose_type),INTENT(INOUT)  :: xp      ! Transpose variables.

   INTEGER,      INTENT(OUT)        :: ids,ide, jds,jde, kds,kde   ! domain dims.
   INTEGER,      INTENT(OUT)        :: ims,ime, jms,jme, kms,kme   ! memory dims.
   INTEGER,      INTENT(OUT)        :: ips,ipe, jps,jpe, kps,kpe   ! patch  dims.

!--De-reference dimension information stored in the grid data structure.

   ids = grid%sd31
   ide = grid%ed31 - 1
   jds = grid%sd32
   jde = grid%ed32 - 1
   kds = grid%sd33
   kde = grid%ed33 - 1

   ims = grid%sm31
   ime = grid%em31
   jms = grid%sm32
   jme = grid%em32
   kms = grid%sm33
   kme = grid%em33

   ips = grid%sp31
   ipe = grid%ep31
   jps = grid%sp32
   jpe = grid%ep32
   kps = grid%sp33
   kpe = grid%ep33

!--Indices for yz decomposition

   xp%idsx = grid%sd31
   xp%idex = grid%ed31 - 1
   xp%jdsx = grid%sd32
   xp%jdex = grid%ed32 - 1
   xp%kdsx = grid%sd33
   xp%kdex = grid%ed33 - 1

   xp%imsx = grid%sm31x
   xp%imex = grid%em31x
   xp%jmsx = grid%sm32x
   xp%jmex = grid%em32x
   xp%kmsx = grid%sm33x
   xp%kmex = grid%em33x

   xp%itsx = grid%sp31x
   xp%itex = grid%ep31x
   xp%jtsx = grid%sp32x
   xp%jtex = grid%ep32x
   xp%ktsx = grid%sp33x
   xp%ktex = grid%ep33x

   xp%ipsx = grid%sp31x
   xp%ipex = grid%ep31x
   xp%jpsx = grid%sp32x
   xp%jpex = grid%ep32x
   xp%kpsx = grid%sp33x
   xp%kpex = grid%ep33x

!--Indices for xz decomposition

   xp%idsy = grid%sd31
   xp%idey = grid%ed31 - 1
   xp%jdsy = grid%sd32
   xp%jdey = grid%ed32 - 1
   xp%kdsy = grid%sd33
   xp%kdey = grid%ed33 - 1

   xp%imsy = grid%sm31y
   xp%imey = grid%em31y
   xp%jmsy = grid%sm32y
   xp%jmey = grid%em32y
   xp%kmsy = grid%sm33y
   xp%kmey = grid%em33y

   xp%itsy = grid%sp31y
   xp%itey = grid%ep31y
   xp%jtsy = grid%sp32y
   xp%jtey = grid%ep32y
   xp%ktsy = grid%sp33y
   xp%ktey = grid%ep33y

   xp%ipsy = grid%sp31y
   xp%ipey = grid%ep31y
   xp%jpsy = grid%sp32y
   xp%jpey = grid%ep32y
   xp%kpsy = grid%sp33y
   xp%kpey = grid%ep33y

   if(ipe > ide) ipe = ide
   if(jpe > jde) jpe = jde
   if(kpe > kde) kpe = kde

   ! Indices for yz decomposition

   if(xp%itex > ide) xp%itex = ide
   if(xp%jtex > jde) xp%jtex = jde
   if(xp%ktex > kde) xp%ktex = kde

   if(xp%ipex > ide) xp%ipex = ide
   if(xp%jpex > jde) xp%jpex = jde
   if(xp%kpex > kde) xp%kpex = kde

   ! Indices for xz decomposition

   if(xp%itey > ide) xp%itey = ide
   if(xp%jtey > jde) xp%jtey = jde
   if(xp%ktey > kde) xp%ktey = kde

   if(xp%ipey > ide) xp%ipey = ide
   if(xp%jpey > jde) xp%jpey = jde
   if(xp%kpey > kde) xp%kpey = kde

!  Copy xpose dimensions from grid structure to xp structure.

!--Indices for xy decomposition

   xp%ids = ids
   xp%ide = ide
   xp%jds = jds
   xp%jde = jde
   xp%kds = kds
   xp%kde = kde

   xp%ims = ims
   xp%ime = ime
   xp%jms = jms
   xp%jme = jme
   xp%kms = kms
   xp%kme = kme

   xp%ips = ips
   xp%ipe = ipe
   xp%jps = jps
   xp%jpe = jpe
   xp%kps = kps
   xp%kpe = kpe

END SUBROUTINE copy_dims

SUBROUTINE copy_tile_dims( grid, xp, its, ite, jts, jte, kts, kte )

!------------------------------------------------------------------------------
!  PURPOSE: Copy tile dimensions from grid structure.
!
!------------------------------------------------------------------------------

!   USE module_domain
   TYPE(domain), INTENT(IN)         :: grid
   TYPE (xpose_type),INTENT(INOUT)  :: xp      ! Transpose variables.
   INTEGER,      INTENT(OUT)        :: its,ite, jts,jte, kts,kte ! tile dims.

   INTEGER                  :: ij   ! Loop counter

!  De-reference tile indices stored in the grid data structure.

   DO ij = 1 , grid%num_tiles
     its = grid%i_start(ij)
     ite = grid%i_end(ij)
     jts = grid%j_start(ij)
     jte = grid%j_end(ij)
     kts = xp%kds
     kte = xp%kde

     xp%its = its
     xp%ite = ite
     xp%jts = jts
     xp%jte = jte
     xp%kts = kts
     xp%kte = kte

     if(xp%ite > xp%ide) xp%ite = xp%ide
     if(xp%jte > xp%jde) xp%jte = xp%jde
     if(xp%kte > xp%kde) xp%kte = xp%kde

     if(ite > xp%ide) ite = xp%ide
     if(jte > xp%jde) jte = xp%jde
     if(kte > xp%kde) kte = xp%kde

        write(unit=*, fmt='(/)')
        write(unit=*, fmt='(A,i3,A,5x,3(i3,A,i3,5x))') 'Tile ',ij, &
                ' size:', its,':',ite, jts,':',jte, kts,':',kte
   END DO
END SUBROUTINE copy_tile_dims

END MODULE module_kma2netcdf_interface


	SUBROUTINE TA_BFIF  ( iubfma, iret )
C************************************************************************
C* TA_BFIF								*
C*									*
C* This subroutine decodes a report from an input BUFR message,		*
C* converts it into interface output, and then writes the interface	*
C* output into the interface arrays.					*
C*									*
C* TA_BFIF  ( IUBFMA, IRET )						*
C*									*
C* Input parameters:							*
C*	IUBFMA		INTEGER		Logical unit number of BUFR	*
C*					messages file			*
C*									*
C* Output parameters:							*
C*	CIVALS (IRACRN)	CHAR		Aircraft tail number
C*	RIVALS (IRYEAR)	REAL		Report year			*
C*	RIVALS (IRMNTH)	REAL		Report month			*
C*	RIVALS (IRDAYS)	REAL		Report day			*
C*	RIVALS (IRHOUR)	REAL		Report hour			*
C*	RIVALS (IRMINU)	REAL		Report minute			*
C*	RIVALS (IRSECO)	REAL		Report second                   *
*	RIVALS (IRSLAT)	REAL		latitude    			*
C*	RIVALS (IRSLON)	REAL		longitude 			*
C*	IRET		INTEGER		Return code:			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C  C. Caruso Magee/NCEP 08/06   New                                     *
C  C. Caruso Magee/NCEP 09/06   Add ermiss check on tpqc2 to reset to   *
C                               value of 3 if all bits are set.         *
C  C. Caruso Magee/NCEP 10/07   Add pressure.                           *
C* J. Ator/NCEP		10/08	Add ACTP and OBSVR, and adjust PCCF	*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'tacmn.cmn'
C*
	PARAMETER	( NTPQC = 7 )
C*
        REAL*8		r8tpqc ( NTPQC )
        real            rtpqc ( NTPQC )
C*
	INCLUDE		'ERMISS.FNC'
C*-----------------------------------------------------------------------
	iret = 0
C
        CALL UT_BFCI  ( iubfma, 'ACRN', civals ( icacrn ), ierbci )
        CALL UT_BFCI  ( iubfma, 'ACTP', civals ( icactp ), ierbci )
        CALL UT_BFCI  ( iubfma, 'OBSVR', civals ( icobsv ), ierbci )
C
	CALL UT_BFRI  ( iubfma, 'YEAR', rivals ( iryear ), ierbri )
	CALL UT_BFRI  ( iubfma, 'MNTH', rivals ( irmnth ), ierbri )
	CALL UT_BFRI  ( iubfma, 'DAYS', rivals ( irdays ), ierbri )
	CALL UT_BFRI  ( iubfma, 'HOUR', rivals ( irhour ), ierbri )
	CALL UT_BFRI  ( iubfma, 'MINU', rivals ( irminu ), ierbri )
	CALL UT_BFRI  ( iubfma, 'SECO', rivals ( irseco ), ierbri )
	CALL UT_BFRI  ( iubfma, 'CLATH', rivals ( irslat ), ierbri )
	CALL UT_BFRI  ( iubfma, 'CLONH', rivals ( irslon ), ierbri )
	CALL UT_BFRI  ( iubfma, 'HMSL', rivals ( irhmsl ), ierbri )
	CALL UT_BFRI  ( iubfma, 'PRLC', rivals ( irprlc ), ierbri )
	CALL UT_BFRI  ( iubfma, 'FLVLST', rivals ( irflvl ), ierbri )
	CALL UT_BFRI  ( iubfma, 'POAF', rivals ( irpoaf ), ierbri )
	CALL UT_BFRI  ( iubfma, 'IALR', rivals ( irialr ), ierbri )
	CALL UT_BFRI  ( iubfma, 'SMMO', rivals ( irsmmo ), ierbri )
	CALL UT_BFRI  ( iubfma, 'TMDBST', rivals ( irtmdb ), ierbri )
	CALL UT_BFRI  ( iubfma, 'WDIR', rivals ( irwdir ), ierbri )
	CALL UT_BFRI  ( iubfma, 'WSPD', rivals ( irwspd ), ierbri )
	CALL UT_BFRI  ( iubfma, 'TRBXST', rivals ( irtrbx ), ierbri )
	CALL UT_BFRI  ( iubfma, 'TOPEDR', rivals ( irtedr ), ierbri )
	CALL UT_BFRI  ( iubfma, 'AFIC', rivals ( irafic ), ierbri )
	CALL UT_BFRI  ( iubfma, 'RAWHU', rivals ( irrehu ), ierbri )
C
C*	The value being reported for PCCF is actually the percent
C*	uncertainty rather than the percent confidence, so compute
C*	the latter from the former.
C
	CALL UT_BFRI  ( iubfma, 'PCCF', rpcf, ierbri )
	IF ( .not. ERMISS ( rpcf ) ) THEN
	    rivals ( irpccf ) = 100. - rpcf
	END IF
C
C*      Store the number of replications for each repeated variable.
C
        rivals ( irntqc ) = 7
C
C*      Decode and store the assoc. field significance data (i.e. the
C*      quality control bits).
C
	CALL UFBREP  ( iubfma, r8tpqc, 1, NTPQC, ierufb, 'TPQC2' )
        DO i = 1, NTPQC
          rtpqc (i)  = UT_BMRI ( r8tpqc (i) )
          IF  ( ERMISS ( rtpqc (i) ) ) THEN
            rivals ( irtpqc (i) ) = 3.0
          ELSE
            rivals ( irtpqc (i) ) = rtpqc (i)
          END IF
        END DO
C*
        RETURN
	END


      subroutine prep (neq, y, yh, savf, ewt, ftem, ia, ja,
     1                     wk, iwk, ipper, f, jac)
clll. optimize
      external f,jac
      integer neq, ia, ja, iwk, ipper
      integer iownd, iowns,
     1   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     2   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      integer iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
     1   ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
     2   lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
     3   nslj, ngp, nlu, nnz, nsp, nzl, nzu
      integer i, ibr, ier, ipil, ipiu, iptt1, iptt2, j, jfound, k,
     1   knew, kmax, kmin, ldif, lenigp, liwk, maxg, np1, nzsut
      double precision y, yh, savf, ewt, ftem, wk
      double precision rowns,
     1   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround
      double precision con0, conmin, ccmxj, psmall, rbig, seth
      double precision dq, dyj, erwt, fac, yj
      dimension neq(1), y(1), yh(1), savf(1), ewt(1), ftem(1),
     1   ia(1), ja(1), wk(1), iwk(1)
      common /ls0001/ rowns(209),
     2   ccmax, el0, h, hmin, hmxi, hu, rc, tn, uround,
     3   iownd(14), iowns(6),
     4   icf, ierpj, iersl, jcur, jstart, kflag, l, meth, miter,
     5   maxord, maxcor, msbp, mxncf, n, nq, nst, nfe, nje, nqu
      common /lss001/ con0, conmin, ccmxj, psmall, rbig, seth,
     1   iplost, iesp, istatc, iys, iba, ibian, ibjan, ibjgp,
     2   ipian, ipjan, ipjgp, ipigp, ipr, ipc, ipic, ipisp, iprsp, ipa,
     3   lenyh, lenyhm, lenwk, lreq, lrat, lrest, lwmin, moss, msbj,
     4   nslj, ngp, nlu, nnz, nsp, nzl, nzu
c-----------------------------------------------------------------------
c this routine performs preprocessing related to the sparse linear
c systems that must be solved if miter = 1 or 2.
c the operations that are performed here are..
c  * compute sparseness structure of jacobian according to moss,
c  * compute grouping of column indices (miter = 2),
c  * compute a new ordering of rows and columns of the matrix,
c  * reorder ja corresponding to the new ordering,
c  * perform a symbolic lu factorization of the matrix, and
c  * set pointers for segments of the iwk/wk array.
c in addition to variables described previously, prep uses the
c following for communication..
c yh     = the history array.  only the first column, containing the
c          current y vector, is used.  used only if moss .ne. 0.
c savf   = a work array of length neq, used only if moss .ne. 0.
c ewt    = array of length neq containing (inverted) error weights.
c          used only if moss = 2 or if istate = moss = 1.
c ftem   = a work array of length neq, identical to acor in the driver,
c          used only if moss = 2.
c wk     = a real work array of length lenwk, identical to wm in
c          the driver.
c iwk    = integer work array, assumed to occupy the same space as wk.
c lenwk  = the length of the work arrays wk and iwk.
c istatc = a copy of the driver input argument istate (= 1 on the
c          first call, = 3 on a continuation call).
c iys    = flag value from odrv or cdrv.
c ipper  = output error flag with the following values and meanings..
c          0  no error.
c         -1  insufficient storage for internal structure pointers.
c         -2  insufficient storage for jgroup.
c         -3  insufficient storage for odrv.
c         -4  other error flag from odrv (should never occur).
c         -5  insufficient storage for cdrv.
c         -6  other error flag from cdrv.
c-----------------------------------------------------------------------
      ibian = lrat*2
      ipian = ibian + 1
      np1 = n + 1
      ipjan = ipian + np1
      ibjan = ipjan - 1
      liwk = lenwk*lrat
      if (ipjan+n-1 .gt. liwk) go to 210
      if (moss .eq. 0) go to 30
c
      if (istatc .eq. 3) go to 20
c istate = 1 and moss .ne. 0.  perturb y for structure determination. --
      do 10 i = 1,n
        erwt = 1.0d0/ewt(i)
        fac = 1.0d0 + 1.0d0/(dfloat(i)+1.0d0)
        y(i) = y(i) + fac*dsign(erwt,y(i))
 10     continue
      go to (70, 100), moss
c
 20   continue
c istate = 3 and moss .ne. 0.  load y from yh(*,1). --------------------
      do 25 i = 1,n
 25     y(i) = yh(i)
      go to (70, 100), moss
c
c moss = 0.  process user-s ia,ja.  add diagonal entries if necessary. -
 30   knew = ipjan
      kmin = ia(1)
      iwk(ipian) = 1
      do 60 j = 1,n
        jfound = 0
        kmax = ia(j+1) - 1
        if (kmin .gt. kmax) go to 45
        do 40 k = kmin,kmax
          i = ja(k)
          if (i .eq. j) jfound = 1
          if (knew .gt. liwk) go to 210
          iwk(knew) = i
          knew = knew + 1
 40       continue
        if (jfound .eq. 1) go to 50
 45     if (knew .gt. liwk) go to 210
        iwk(knew) = j
        knew = knew + 1
 50     iwk(ipian+j) = knew + 1 - ipjan
        kmin = kmax + 1
 60     continue
      go to 140
c
c moss = 1.  compute structure from user-supplied jacobian routine jac.
 70   continue
c a dummy call to f allows user to create temporaries for use in jac. --
      call f (neq, tn, y, savf)
      k = ipjan
      iwk(ipian) = 1
      do 90 j = 1,n
        if (k .gt. liwk) go to 210
        iwk(k) = j
        k = k + 1
        do 75 i = 1,n
 75       savf(i) = 0.0d0
        call jac (neq, tn, y, j, iwk(ipian), iwk(ipjan), savf)
        do 80 i = 1,n
          if (dabs(savf(i)) .le. seth) go to 80
          if (i .eq. j) go to 80
          if (k .gt. liwk) go to 210
          iwk(k) = i
          k = k + 1
 80       continue
        iwk(ipian+j) = k + 1 - ipjan
 90     continue
      go to 140
c
c moss = 2.  compute structure from results of n + 1 calls to f. -------
 100  k = ipjan
      iwk(ipian) = 1
      call f (neq, tn, y, savf)
      do 120 j = 1,n
        if (k .gt. liwk) go to 210
        iwk(k) = j
        k = k + 1
        yj = y(j)
        erwt = 1.0d0/ewt(j)
        dyj = dsign(erwt,yj)
        y(j) = yj + dyj
        call f (neq, tn, y, ftem)
        y(j) = yj
        do 110 i = 1,n
          dq = (ftem(i) - savf(i))/dyj
          if (dabs(dq) .le. seth) go to 110
          if (i .eq. j) go to 110
          if (k .gt. liwk) go to 210
          iwk(k) = i
          k = k + 1
 110      continue
        iwk(ipian+j) = k + 1 - ipjan
 120    continue
c
 140  continue
      if (moss .eq. 0 .or. istatc .ne. 1) go to 150
c if istate = 1 and moss .ne. 0, restore y from yh. --------------------
      do 145 i = 1,n
 145    y(i) = yh(i)
 150  nnz = iwk(ipian+n) - 1
      lenigp = 0
      ipigp = ipjan + nnz
      if (miter .ne. 2) go to 160
c
c compute grouping of column indices (miter = 2). ----------------------
      maxg = np1
      ipjgp = ipjan + nnz
      ibjgp = ipjgp - 1
      ipigp = ipjgp + n
      iptt1 = ipigp + np1
      iptt2 = iptt1 + n
      lreq = iptt2 + n - 1
      if (lreq .gt. liwk) go to 220
      call jgroup (n, iwk(ipian), iwk(ipjan), maxg, ngp, iwk(ipigp),
     1   iwk(ipjgp), iwk(iptt1), iwk(iptt2), ier)
      if (ier .ne. 0) go to 220
      lenigp = ngp + 1
c
c compute new ordering of rows/columns of jacobian. --------------------
 160  ipr = ipigp + lenigp
      ipc = ipr
      ipic = ipc + n
      ipisp = ipic + n
      iprsp = (ipisp - 2)/lrat + 2
      iesp = lenwk + 1 - iprsp
      if (iesp .lt. 0) go to 230
      ibr = ipr - 1
      do 170 i = 1,n
 170    iwk(ibr+i) = i
      nsp = liwk + 1 - ipisp
      call odrv (n, iwk(ipian), iwk(ipjan), wk, iwk(ipr), iwk(ipic),
     1   nsp, iwk(ipisp), 1, iys)
      if (iys .eq. 11*n+1) go to 240
      if (iys .ne. 0) go to 230
c
c reorder jan and do symbolic lu factorization of matrix. --------------
      ipa = lenwk + 1 - nnz
      nsp = ipa - iprsp
      lreq = max0(12*n/lrat, 6*n/lrat+2*n+nnz) + 3
      lreq = lreq + iprsp - 1 + nnz
      if (lreq .gt. lenwk) go to 250
      iba = ipa - 1
      do 180 i = 1,nnz
 180    wk(iba+i) = 0.0d0
      ipisp = lrat*(iprsp - 1) + 1
      call cdrv (n,iwk(ipr),iwk(ipc),iwk(ipic),iwk(ipian),iwk(ipjan),
     1   wk(ipa),wk(ipa),wk(ipa),nsp,iwk(ipisp),wk(iprsp),iesp,5,iys)
      lreq = lenwk - iesp
      if (iys .eq. 10*n+1) go to 250
      if (iys .ne. 0) go to 260
      ipil = ipisp
      ipiu = ipil + 2*n + 1
      nzu = iwk(ipil+n) - iwk(ipil)
      nzl = iwk(ipiu+n) - iwk(ipiu)
      if (lrat .gt. 1) go to 190
      call adjlr (n, iwk(ipisp), ldif)
      lreq = lreq + ldif
 190  continue
      if (lrat .eq. 2 .and. nnz .eq. n) lreq = lreq + 1
      nsp = nsp + lreq - lenwk
      ipa = lreq + 1 - nnz
      iba = ipa - 1
      ipper = 0
      return
c
 210  ipper = -1
      lreq = 2 + (2*n + 1)/lrat
      lreq = max0(lenwk+1,lreq)
      return
c
 220  ipper = -2
      lreq = (lreq - 1)/lrat + 1
      return
c
 230  ipper = -3
      call cntnzu (n, iwk(ipian), iwk(ipjan), nzsut)
      lreq = lenwk - iesp + (3*n + 4*nzsut - 1)/lrat + 1
      return
c
 240  ipper = -4
      return
c
 250  ipper = -5
      return
c
 260  ipper = -6
      lreq = lenwk
      return
c----------------------- end of subroutine prep ------------------------
      end


SUBROUTINE xtrack_radiance_wvl_calibration (             &
     yn_radiance_reference, yn_solar_comp,               &
     first_pix, last_pix, n_max_rspec, n_comm_wvl_out, errstat )

  USE OMSAO_precision_module
  USE OMSAO_indices_module,    ONLY: &
       wvl_idx, spc_idx, sig_idx, max_calfit_idx, max_rs_idx, hwe_idx, asy_idx,  &
       shi_idx, squ_idx, oclo_idx, o2o2_idx, bro_idx, solar_idx, pge_bro_idx,    &
       pge_oclo_idx, ccd_idx, radcal_idx
  USE OMSAO_parameters_module, ONLY: maxchlen, downweight, normweight
  USE OMSAO_variables_module,  ONLY:  &
       verb_thresh_lev, hw1e, e_asym, n_rad_wvl, curr_rad_spec, rad_spec_wavcal, &
       sol_wav_avg, database, fitvar_cal, fitvar_cal_saved,                      &
       fitvar_rad_init, pge_idx, rad_wght_wavcal,         &
       n_fitres_loop, fitres_range, yn_diagnostic_run
  USE OMSAO_slitfunction_module, ONLY: saved_shift, saved_squeeze
  USE OMSAO_omidata_module ! , exept_this_one => n_comm_wvl
  USE OMSAO_errstat_module
  USE EZspline_obj
  USE EZspline

  IMPLICIT NONE

  ! ---------------
  ! Input variables
  ! ---------------
  INTEGER (KIND=i4), INTENT (IN) :: first_pix, last_pix, n_max_rspec
  LOGICAL,           INTENT (IN) :: yn_radiance_reference, yn_solar_comp

  ! ---------------
  ! Output variable
  ! ---------------
  INTEGER (KIND=i4), INTENT (OUT) :: n_comm_wvl_out

  ! -----------------
  ! Modified variable
  ! -----------------
  INTEGER (KIND=i4), INTENT (INOUT) :: errstat

  ! ---------------
  ! Local variables
  ! ---------------
  INTEGER   (KIND=i2)      :: radcal_itnum
  INTEGER   (KIND=i4)      :: locerrstat, ipix, radcal_exval, i, imax, n_ref_wvl !, nxtloc, xtr_add
  REAL      (KIND=r8)      :: chisquav, rad_spec_avg
  LOGICAL                  :: yn_skip_pix, yn_bad_pixel, yn_full_range
  CHARACTER (LEN=maxchlen) :: addmsg
  INTEGER (KIND=i4), DIMENSION (4)            :: select_idx
  INTEGER (KIND=i4), DIMENSION (2)            :: exclud_idx
  REAL    (KIND=r8), DIMENSION (n_max_rspec) :: ref_wvl, ref_spc, ref_wgt, rad_wvl

  ! ------------------------------
  ! Name of this module/subroutine
  ! ------------------------------
  CHARACTER (LEN=31), PARAMETER :: modulename = 'xtrack_radiance_wvl_calibration'

  locerrstat = pge_errstat_ok

  fitvar_cal_saved(1:max_calfit_idx) = fitvar_rad_init(1:max_calfit_idx)

  ! -------------------------------------------------
  ! Set the number of wavelengths for the common mode
  ! -------------------------------------------------
  n_comm_wvl_out = MAXVAL ( omi_nwav_radref(first_pix:last_pix) )
  IF ( MAXVAL(omi_nwav_rad(first_pix:last_pix,0)) > n_comm_wvl_out ) &
    n_comm_wvl_out = MAXVAL(omi_nwav_rad(first_pix:last_pix,0))

  ! --------------------------------
  ! Loop over cross-track positions.
  ! --------------------------------
  XTrackWavCal: DO ipix = first_pix, last_pix

     locerrstat = pge_errstat_ok

     curr_xtrack_pixnum = ipix

     ! ---------------------------------------------------------------------
     ! If we already determined that this cross track pixel position carries
     ! an error, we don't even have to start processing.
     ! ---------------------------------------------------------------------
     IF ( omi_cross_track_skippix(ipix) ) CYCLE

     ! ---------------------------------------------------------------------------
     ! For each cross-track position we have to initialize the saved Shift&Squeeze
     ! ---------------------------------------------------------------------------
     saved_shift = -1.0e+30_r8 ; saved_squeeze = -1.0e+30_r8

     ! ----------------------------------------------------
     ! Assign number of radiance and irradiance wavelengths
     ! ----------------------------------------------------
     n_omi_irradwvl = omi_nwav_irrad(ipix  )
     n_omi_radwvl   = omi_nwav_rad  (ipix,0)

     ! -----------------------------------------------------------------
     ! tpk: Should the following be "> n_fitvar_rad"??? No, because that
     !      value is set only inside OMI_ADJUST_RADIANCE_DATA!!!
     ! -----------------------------------------------------------------
     IF ( n_omi_irradwvl <= 0 .OR. n_omi_radwvl <= 0 ) CYCLE

     ! ---------------------------------------------------------------
     ! Restore solar fitting variables for across-track reference in
     ! Earthshine fitting. Use the Radiance References if appropriate.
     ! ---------------------------------------------------------------
     sol_wav_avg = omi_sol_wav_avg(ipix)
     hw1e        = omi_solcal_pars(hwe_idx,ipix)
     e_asym      = omi_solcal_pars(asy_idx,ipix)

     ! -----------------------------------------------------
     ! Assign (hopefully predetermined) "reference" weights.
     ! -----------------------------------------------------
     IF ( .NOT. yn_solar_comp ) THEN
        n_omi_irradwvl            = omi_nwav_irrad(ipix)
        ref_wgt(1:n_omi_irradwvl) = omi_irradiance_wght(1:n_omi_irradwvl,ipix)

       ! -----------------------------------------------------
       ! Catch the possibility that N_OMI_RADWVL > N_OMI_IRRADWVL
       ! -----------------------------------------------------
       IF ( n_omi_radwvl > n_omi_irradwvl ) THEN
          i = n_omi_radwvl - n_omi_irradwvl
          ref_wgt(n_omi_irradwvl+1:n_omi_irradwvl+i) = downweight
          n_omi_irradwvl = n_omi_radwvl
       END IF
     ELSE
        n_omi_irradwvl          = n_omi_radwvl
        ref_wgt(1:n_omi_radwvl) = normweight
     END IF

     ! ---------------------------------------------------------------
     ! If a Radiance Reference is being used, then it must be calibrated
     ! rather than the swath line that has been read.
     ! ---------------------------------------------------------------
     IF ( yn_radiance_reference ) THEN
        omi_radiance_wavl(1:n_omi_radwvl,ipix,0) = omi_radref_wavl(1:n_omi_radwvl,ipix)
        omi_radiance_spec(1:n_omi_radwvl,ipix,0) = omi_radref_spec(1:n_omi_radwvl,ipix)
        omi_radiance_qflg(1:n_omi_radwvl,ipix,0) = omi_radref_qflg(1:n_omi_radwvl,ipix)
     END IF

     ! ---------------------------------------------------------------------------
     ! Set up generic fitting arrays. Remember that OMI_RADIANCE_XXX arrays are
     ! 3-dim with the last dimension being the scan line numbers. For the radiance
     ! wavelength calibration we only have one scan line at index "0".
     ! ---------------------------------------------------------------------------
     select_idx(1:4) = omi_ccdpix_selection(ipix,1:4)
     exclud_idx(1:2) = omi_ccdpix_exclusion(ipix,1:2)

     CALL omi_adjust_radiance_data ( &           ! Set up generic fitting arrays
          select_idx(1:4), exclud_idx(1:2),            &
          n_omi_radwvl,                                &
          omi_radiance_wavl  (1:n_omi_radwvl,ipix,0),  &
          omi_radiance_spec  (1:n_omi_radwvl,ipix,0),  &
          omi_radiance_qflg  (1:n_omi_radwvl,ipix,0),  &
          omi_radiance_ccdpix(1:n_omi_radwvl,ipix,0),  &
          n_omi_irradwvl, ref_wgt(1:n_omi_irradwvl),   &
          n_rad_wvl, curr_rad_spec(wvl_idx:ccd_idx,1:n_omi_radwvl), rad_spec_avg, &
          yn_skip_pix )

     ! ------------------------------------------------------------------------------------
     IF ( yn_skip_pix .OR. locerrstat >= pge_errstat_error ) THEN
        errstat = MAX ( errstat, locerrstat )
        omi_cross_track_skippix (ipix) = .TRUE.
        addmsg = ''
        WRITE (addmsg, '(A,I2)') 'SKIPPING cross track pixel #', ipix
        CALL error_check ( 0, 1, pge_errstat_warning, OMSAO_W_SKIPPIX, &
             modulename//f_sep//TRIM(ADJUSTL(addmsg)), vb_lev_default, &
             locerrstat )
        CYCLE
     END IF

     ! -----------------------------------------------------
     ! Assign the solar average wavelength - the wavelength
     ! calibration will not converge without it!
     ! -----------------------------------------------------
     sol_wav_avg = &
          SUM ( curr_rad_spec(wvl_idx,1:n_omi_radwvl) ) / REAL(n_omi_radwvl,KIND=r8)
     yn_bad_pixel = .FALSE.
     CALL radiance_wavcal ( &                       ! Radiance wavelength calibration
          ipix, n_fitres_loop(radcal_idx), fitres_range(radcal_idx),       &
          n_rad_wvl, curr_rad_spec(wvl_idx:ccd_idx,1:n_rad_wvl),           &
          radcal_exval, radcal_itnum, chisquav, yn_bad_pixel, locerrstat )

     IF ( yn_bad_pixel .OR. locerrstat >= pge_errstat_error ) THEN
        errstat = MAX ( errstat, locerrstat )
        omi_cross_track_skippix (ipix) = .TRUE.
        addmsg = ''
        WRITE (addmsg, '(A,I2)') 'SKIPPING cross track pixel #', ipix
        CALL error_check ( 0, 1, pge_errstat_warning, OMSAO_W_SKIPPIX, &
             modulename//f_sep//TRIM(ADJUSTL(addmsg)), vb_lev_default, &
             locerrstat )
        CYCLE
     END IF
     ! ------------------------------------------------------------------------------------

     addmsg = ''
     WRITE (addmsg, '(A,I2,4(A,1PE10.3),2(A,I5))') 'RADIANCE Wavcal    #', ipix, &
          ': hw 1/e = ', hw1e, '; e_asy = ', e_asym, '; shift = ', &
          fitvar_cal(shi_idx), '; squeeze = ', fitvar_cal(squ_idx), &
         '; exit val = ', radcal_exval, '; iter num = ', radcal_itnum
     CALL error_check ( &
          0, 1, pge_errstat_ok, OMSAO_S_PROGRESS, TRIM(ADJUSTL(addmsg)), &
          vb_lev_omidebug, locerrstat )
     IF ( verb_thresh_lev >= vb_lev_screen ) WRITE (*, '(A)') TRIM(ADJUSTL(addmsg))

     ! ---------------------------------
     ! Save crucial variables for output
     ! ---------------------------------
     omi_radcal_pars (1:max_calfit_idx,ipix) = fitvar_cal(1:max_calfit_idx)
     omi_radcal_xflag(ipix)                  = INT (radcal_exval, KIND=i2)
     omi_radcal_itnum(ipix)                  = INT (radcal_itnum, KIND=i2)
     omi_radcal_chisq(ipix)                  = chisquav
     ! -----------------------------------------------------------------------

     IF ( .NOT. (yn_radiance_reference) ) THEN
        n_ref_wvl = n_omi_irradwvl
        ref_wvl(1:n_ref_wvl) = omi_irradiance_wavl(1:n_ref_wvl,ipix)
        ref_spc(1:n_ref_wvl) = omi_irradiance_spec(1:n_ref_wvl,ipix)
        ref_wgt(1:n_ref_wvl) = omi_irradiance_wght(1:n_ref_wvl,ipix)
     ELSE
        n_ref_wvl = n_rad_wvl
        ref_wvl(1:n_ref_wvl) = curr_rad_spec(wvl_idx,1:n_rad_wvl)
        ref_spc(1:n_ref_wvl) = curr_rad_spec(spc_idx,1:n_rad_wvl)
        ref_wgt(1:n_ref_wvl) = curr_rad_spec(sig_idx,1:n_rad_wvl)

        omi_nwav_radref(ipix)             = n_ref_wvl
        omi_radref_wavl(1:n_ref_wvl,ipix) = curr_rad_spec(wvl_idx,1:n_rad_wvl)
        omi_radref_spec(1:n_ref_wvl,ipix) = curr_rad_spec(spc_idx,1:n_rad_wvl)
        omi_radref_wght(1:n_ref_wvl,ipix) = curr_rad_spec(sig_idx,1:n_rad_wvl)
     END IF

     ! ----------------------------------------------------
     ! Spline reference spectra to current wavelength grid.
     ! ----------------------------------------------------
     rad_wvl(1:n_rad_wvl) = curr_rad_spec(wvl_idx,1:n_rad_wvl)
     Call prepare_databases ( &
          ipix, n_ref_wvl, ref_wvl(1:n_ref_wvl), ref_spc(1:n_ref_wvl), &
          n_rad_wvl, rad_wvl(1:n_rad_wvl), n_max_rspec, locerrstat )
     ! --------------------------------------------------------------------------------

     IF ( locerrstat >= pge_errstat_error ) EXIT XTrackWavCal

     ! ---------------------------------------------------------
     ! Save DATABASE in OMI_DATABASE for radiance fitting loops.
     ! ---------------------------------------------------------
     omi_database (1:max_rs_idx,1:n_rad_wvl,ipix) = database (1:max_rs_idx,1:n_rad_wvl)
     n_omi_database_wvl(ipix)                     = n_rad_wvl
     omi_database_wvl(1:n_rad_wvl, ipix)          = curr_rad_spec(wvl_idx,1:n_rad_wvl)

     ! ----------------------------------------------------------------------
     ! Update the radiance reference with the wavelength calibrated values.
     ! ----------------------------------------------------------------------
     IF ( yn_radiance_reference ) THEN
        omi_radref_wavl(1:n_rad_wvl,ipix) = curr_rad_spec(wvl_idx,1:n_rad_wvl)
        omi_radref_spec(1:n_rad_wvl,ipix) = curr_rad_spec(spc_idx,1:n_rad_wvl)
        omi_radref_wght(n_rad_wvl+1:nwavel_max,ipix) = downweight

        ! --------------------------------------------------------
        ! Update the solar spectrum entry in OMI_DATABASE. First
        ! re-sample the solar reference spectrum to the OMI grid
        ! then assign to data base.
        !
        ! We need to keep the irradiance spectrum because we still
        ! have to fit the radiance reference, and we can't really
        ! do that against itself. In a later module the irradiance
        ! is replaced by the radiance reference.
        ! --------------------------------------------------------

        ! ------------------------------------------------------------------
        ! Prevent failure of interpolation by finding the maximum wavelength
        ! of the irradiance wavelength array.
        ! ------------------------------------------------------------------
        imax = MAXVAL ( MAXLOC ( omi_irradiance_wavl(1:n_omi_irradwvl,ipix) ) )
        !imin = MINVAL ( MINLOC ( omi_irradiance_wavl(1:imax,          ipix) ) )

        CALL interpolation ( &
             modulename, &
             imax, omi_irradiance_wavl(1:imax,ipix),                     &
             omi_irradiance_spec(1:imax,ipix),                           &
             n_rad_wvl, omi_database_wvl(1:n_rad_wvl,ipix),              &
             omi_database(solar_idx,1:n_rad_wvl,ipix),                   &
             'endpoints', 0.0_r8, yn_full_range, locerrstat )

        IF ( locerrstat >= pge_errstat_error ) THEN
           errstat = MAX ( errstat, locerrstat )
           omi_cross_track_skippix (ipix) = .TRUE.
           addmsg = ''
           WRITE (addmsg, '(A,I2)') 'SKIPPING cross track pixel #', ipix
           CALL error_check ( 0, 1, pge_errstat_warning, OMSAO_W_SKIPPIX, &
                modulename//f_sep//TRIM(ADJUSTL(addmsg)), vb_lev_default, &
                locerrstat )
           CYCLE
        END IF

     END IF

  END DO XTrackWavCal

  ! CCM Write splined/convolved databases if necessary
  IF( yn_diagnostic_run ) THEN
     ! omi_database maybe omi_database_wvl?
     CALL he5_write_omi_database(omi_database(1:max_rs_idx,1:n_rad_wvl,1:nxtrack_max), &
          omi_database_wvl(1:n_rad_wvl, 1:nxtrack_max), &
          max_rs_idx, n_rad_wvl, nxtrack_max, errstat)

  ENDIF

  errstat = MAX ( errstat, locerrstat )

  RETURN
END SUBROUTINE xtrack_radiance_wvl_calibration

SUBROUTINE xtrack_radiance_fitting_loop (                             &
     n_max_rspec, first_pix, last_pix, pge_idx, iloop,                &
     ctr_maxcol, n_fitvar_rad, allfit_cols, allfit_errs, corr_matrix, &
     target_var, errstat, fitspc_out, fitspc_out_dim0                 )

  USE OMSAO_precision_module
  USE OMSAO_indices_module,    ONLY: &
       wvl_idx, spc_idx, sig_idx, o3_t1_idx, o3_t3_idx, hwe_idx, asy_idx, shi_idx, squ_idx, &
       pge_o3_idx, pge_hcho_idx, n_max_fitpars, solar_idx, ccd_idx, radfit_idx, bro_idx,    &
       pge_gly_idx
  USE OMSAO_parameters_module, ONLY: &
       i2_missval, i4_missval, r4_missval, r8_missval, maxchlen, elsunc_less_is_noise
  USE OMSAO_variables_module,  ONLY:  &
       database, curr_sol_spec, n_rad_wvl, curr_rad_spec, sol_wav_avg, hw1e, e_asym,     &
       verb_thresh_lev, fitvar_rad_saved, fitvar_rad_init, n_database_wvl, &
       fitvar_rad, rad_wght_wavcal, n_fitres_loop, fitres_range, refspecs_original,      &
       yn_solar_comp, max_itnum_rad, szamax, n_fincol_idx, ozone_idx, ozone_log
  USE OMSAO_radiance_ref_module, ONLY: yn_radiance_reference, yn_reference_fit
  USE OMSAO_slitfunction_module, ONLY: saved_shift, saved_squeeze
  USE OMSAO_prefitcol_module, ONLY: &
       yn_o3_prefit,  o3_prefit_col,  o3_prefit_dcol,  &
       yn_bro_prefit, bro_prefit_col, bro_prefit_dcol, &
       yn_lqh2o_prefit, lqh2o_prefit_col, lqh2o_prefit_dcol
  USE OMSAO_omidata_module  ! nxtrack_max, ...
  USE OMSAO_errstat_module

  IMPLICIT NONE

  ! ---------------
  ! Input Variables
  ! ---------------
  REAL    (KIND=r8), INTENT (IN) :: ctr_maxcol
  INTEGER (KIND=i4), INTENT (IN) :: &
       pge_idx, iloop, first_pix, last_pix, n_max_rspec, n_fitvar_rad, &
       fitspc_out_dim0

  ! -----------------
  ! Modified variable
  ! -----------------
  INTEGER (KIND=i4), INTENT (INOUT) :: errstat
  REAL    (KIND=r8), INTENT (OUT  ), DIMENSION (n_fitvar_rad,first_pix:last_pix) :: &
       allfit_cols, allfit_errs, corr_matrix

  ! ---------------------------------------------------------
  ! Optional output variable (fitted variable for target gas)
  ! ---------------------------------------------------------
  REAL (KIND=r8), DIMENSION(n_fincol_idx,first_pix:last_pix), INTENT (OUT) :: target_var

  ! CCM Output fit spectra
  !REAL (KIND=r8), DIMENSION(n_comm_wvl,nxtrack_max,4), INTENT (OUT) :: fitspc_out
  REAL (KIND=r8), DIMENSION(fitspc_out_dim0,nxtrack_max,4), INTENT (OUT) :: fitspc_out

  ! ---------------
  ! Local variables
  ! ---------------
  INTEGER (KIND=i4) :: locerrstat, ipix, radfit_exval, radfit_itnum
  REAL    (KIND=r8) :: fitcol, rms, dfitcol, chisquav, rad_spec_avg
  REAL    (KIND=r8) :: brofit_col, brofit_dcol
  REAL    (KIND=r8) :: lqh2ofit_col, lqh2ofit_dcol
  REAL    (KIND=r8), DIMENSION (o3_t1_idx:o3_t3_idx) :: o3fit_cols, o3fit_dcols
  LOGICAL                                     :: yn_skip_pix, yn_cycle_this_pix
  LOGICAL                                     :: yn_bad_pixel
  INTEGER (KIND=i4), DIMENSION (4)            :: select_idx
  INTEGER (KIND=i4), DIMENSION (2)            :: exclud_idx
  INTEGER (KIND=i4)                           :: n_solar_pts
  REAL    (KIND=r8), DIMENSION (n_max_rspec)  :: solar_wvl

  ! CCM Array for holding fitted spectra
  REAL    (KIND=r8), DIMENSION (fitspc_out_dim0) :: fitspc
  REAL    (KIND=i4)                           :: id

  CHARACTER (LEN=28), PARAMETER :: modulename = 'xtrack_radiance_fitting_loop'

  locerrstat = pge_errstat_ok

  !!!fitvar_rad_saved = fitvar_rad_init

  XTrackPix: DO ipix = first_pix, last_pix

     curr_xtrack_pixnum = ipix

     ! ---------------------------------------------------------------------
     ! If we already determined that this cross track pixel position carries
     ! an error, we don't even have to start processing.
     ! ---------------------------------------------------------------------
     IF ( omi_cross_track_skippix(ipix) .OR. szamax < omi_szenith(ipix,iloop) ) CYCLE

     locerrstat = pge_errstat_ok

     n_database_wvl = n_omi_database_wvl(ipix)
     n_omi_radwvl   = omi_nwav_rad      (ipix,iloop)

     ! ---------------------------------------------------------------------------
     ! For each cross-track position we have to initialize the saved Shift&Squeeze
     ! ---------------------------------------------------------------------------
     saved_shift = -1.0e+30_r8 ; saved_squeeze = -1.0e+30_r8

     ! ----------------------------------------------------------------------------
     ! Assign the solar wavelengths. Those should be current in the DATABASE array
     ! and can be taken from there no matter which case - YN_SOLAR_COMP and/or
     ! YN_RADIANCE_REFRENCE we are processing.
     ! ----------------------------------------------------------------------------
     n_solar_pts              = n_omi_database_wvl(ipix)
     if (n_solar_pts < 1) cycle  ! JED fix

     solar_wvl(1:n_solar_pts) = omi_database_wvl  (1:n_solar_pts, ipix)
     n_omi_irradwvl           = n_solar_pts

     CALL check_wavelength_overlap ( &
          n_fitvar_rad,                                                &
          n_solar_pts,          solar_wvl (1:n_solar_pts),             &
          n_omi_radwvl, omi_radiance_wavl (1:n_omi_radwvl,ipix,iloop), &
          yn_cycle_this_pix )

     IF ( yn_cycle_this_pix                .OR. &
          (n_database_wvl <= 0) .OR. (n_omi_radwvl <= 0) ) CYCLE
          !(n_database_wvl <= n_fitvar_rad) .OR. (n_omi_radwvl <= n_fitvar_rad) ) CYCLE

     ! ----------------------------------------------
     ! Restore DATABASE from OMI_DATABASE (see above)
     ! ----------------------------------------------
     database (1:max_rs_idx,1:n_database_wvl) = omi_database (1:max_rs_idx,1:n_database_wvl,ipix)

     ! ---------------------------------------------------------------------------------
     ! Restore solar fitting variables for across-track reference in Earthshine fitting.
     ! Note that, for the YN_SOLAR_COMP case, some variables have been assigned already
     ! in the XTRACK_RADIANCE_WAVCAL loop.
     ! ---------------------------------------------------------------------------------
     sol_wav_avg                             = omi_sol_wav_avg(ipix)
     hw1e                                    = omi_solcal_pars(hwe_idx,ipix)
     e_asym                                  = omi_solcal_pars(asy_idx,ipix)
     curr_sol_spec(wvl_idx,1:n_database_wvl) = omi_database_wvl(1:n_database_wvl,ipix)
     curr_sol_spec(spc_idx,1:n_database_wvl) = omi_database    (solar_idx,1:n_database_wvl,ipix)
     ! --------------------------------------------------------------------------------

     omi_xtrackpix_no = ipix

     ! -------------------------------------------------------------------------
     select_idx(1:4) = omi_ccdpix_selection(ipix,1:4)
     exclud_idx(1:2) = omi_ccdpix_exclusion(ipix,1:2)
     CALL omi_adjust_radiance_data ( &           ! Set up generic fitting arrays
          select_idx(1:4), exclud_idx(1:2),                        &
          n_omi_radwvl,                                            &
          omi_radiance_wavl  (1:n_omi_radwvl,ipix,iloop),          &
          omi_radiance_spec  (1:n_omi_radwvl,ipix,iloop),          &
          omi_radiance_qflg  (1:n_omi_radwvl,ipix,iloop),          &
          omi_radiance_ccdpix(1:n_omi_radwvl,ipix,iloop),          &
          n_omi_radwvl, omi_radref_wght(1:n_omi_radwvl,ipix),      &
          n_rad_wvl, curr_rad_spec(wvl_idx:ccd_idx,1:n_omi_radwvl),&
          rad_spec_avg, yn_skip_pix )

     SELECT CASE ( pge_idx )

     CASE (pge_hcho_idx)
        o3fit_cols (o3_t1_idx:o3_t3_idx) = o3_prefit_col (o3_t1_idx:o3_t3_idx,ipix,iloop)
        o3fit_dcols(o3_t1_idx:o3_t3_idx) = o3_prefit_dcol(o3_t1_idx:o3_t3_idx,ipix,iloop)
        brofit_col                       = bro_prefit_col (ipix,iloop)
        brofit_dcol                      = bro_prefit_dcol(ipix,iloop)

     CASE ( pge_gly_idx )
        lqh2ofit_col                     = lqh2o_prefit_col (ipix,iloop)
        lqh2ofit_dcol                    = lqh2o_prefit_dcol(ipix,iloop)
     CASE DEFAULT
     		! Nothing
     END SELECT

     ! --------------------
     ! The radiance fitting
     ! --------------------
     fitcol       = r8_missval
     dfitcol      = r8_missval
     radfit_exval = INT(i2_missval, KIND=i4)
     radfit_itnum = INT(i2_missval, KIND=i4)
     rms          = r8_missval

     yn_reference_fit = .FALSE.
     IF ( MAXVAL(curr_rad_spec(spc_idx,1:n_rad_wvl)) > 0.0_r8 .AND.     &
          n_rad_wvl > n_fitvar_rad .AND. (.NOT. yn_skip_pix)          ) THEN

        yn_bad_pixel = .FALSE.
        CALL radiance_fit ( &
             pge_idx, ipix, n_fitres_loop(radfit_idx), fitres_range(radfit_idx),   &
             yn_reference_fit,                                                     &
             n_rad_wvl, curr_rad_spec(wvl_idx:ccd_idx,1:n_rad_wvl),                &
             fitcol, rms, dfitcol, radfit_exval, radfit_itnum, chisquav,           &
             o3fit_cols, o3fit_dcols, brofit_col, brofit_dcol,                     &
             lqh2ofit_col, lqh2ofit_dcol,                                          &
             target_var(1:n_fincol_idx,ipix),                                      &
             allfit_cols(1:n_fitvar_rad,ipix), allfit_errs(1:n_fitvar_rad,ipix),   &
             corr_matrix(1:n_fitvar_rad,ipix), yn_bad_pixel, fitspc(1:n_rad_wvl) )

        IF ( yn_bad_pixel ) CYCLE
     END IF

     ! -----------------------------------
     ! Assign pixel values to final arrays
     ! -----------------------------------
     omi_fitconv_flag (ipix,iloop) = INT (radfit_exval, KIND=i2)
     omi_itnum_flag   (ipix,iloop) = INT (radfit_itnum, KIND=i2)
     omi_radfit_chisq (ipix,iloop) = chisquav
     omi_fit_rms      (ipix,iloop) = rms
     omi_column_amount(ipix,iloop) = fitcol
     omi_column_uncert(ipix,iloop) = dfitcol
     IF (ozone_log) THEN
        omi_ozone_amount(ipix,omi_iline)  = allfit_cols(ozone_idx,ipix)
     ENDIF

     ! CCM assign fit residual
     fitspc_out(1:n_rad_wvl,ipix,1) = fitspc(1:n_rad_wvl)
     fitspc_out(1:n_rad_wvl,ipix,2) = curr_rad_spec(spc_idx,1:n_rad_wvl)
     fitspc_out(1:n_rad_wvl,ipix,3) = curr_rad_spec(wvl_idx,1:n_rad_wvl)
     fitspc_out(1:n_rad_wvl,ipix,4) = curr_rad_spec(sig_idx,1:n_rad_wvl)

     IF ( pge_idx == pge_o3_idx ) THEN
        omi_o3_amount(o3_t1_idx:o3_t3_idx,ipix,iloop) = o3fit_cols (o3_t1_idx:o3_t3_idx)
        omi_o3_uncert(o3_t1_idx:o3_t3_idx,ipix,iloop) = o3fit_dcols(o3_t1_idx:o3_t3_idx)
     END IF

  END DO XTrackPix

  errstat = MAX ( errstat, locerrstat )

  RETURN
END SUBROUTINE xtrack_radiance_fitting_loop


C
      SUBROUTINE ABSKO(NEWT,NT,TSKAL,PESKAL,ISETA,J,ABSK,SPRID)
C
C        THE ROUTINE ADMINISTERS THE COMPUTATION OF ABSORPTION
C        COEFFICIENTS. IT CALLS THE ROUTINES, GIVING THE PROPER THERMO-
C        DYNAMIC INFORMATION ( J O N ) , THE DETAILS OF THE ABSORPTION
C        MECHANISMS ( D E T A B S ) AND THE FACTORS FOR THE INTERPOLATION
C        IN T  ( T A B S ) . IT CHOOSES (IF NECESSARY READS) THE RIGHT SET
C        OF ABSORPTION-COEFFICIENT DATA (ISETA), STATEMENT NO. 5 AND MAKES
C        THE INTERPOLATION IN T, STATEMENTS NOS. 10-18, AND THE SUMMATION
C        OF A ROSSELAND MEAN, IF INDICATED BY J = 0, STATEMENTS NOS. 25-28
C
C        NEWT SHOULD BE GT 1 THE FIRST TIME THIS ROUTINE IS USED,
C                       EQ 1 WHEN A NEW SET OF T-PE IS USED,
C                       EQ 0 OTHERWISE.
C
C        NT IS THE NUMBER OF T-PE POINTS. THE TEMPERATURES T SHOULD BE EX-
C        PRESSED IN KELVIN, THE ELECTRON PRESSURES PE IN DYNES PER CM2
C        ISETA IS THE WAVELENGTH-SET NUMBER, J THE WAVELENGTH NUMBER IN THAT
C        SET. J EQUAL TO ZERO INDICATES THAT A ROSSELAND MEAN IS WANTED.
C        THIS MEAN IS COMPUTED USING THE WAVELENGTH POINTS OF THE ACTUAL
C        SET (ISETA) AND THE QUADRATURE WEIGHTS GIVEN IN ROSW.
C        IN ABSK AND SPRID THE ABSORPTION AND SCATTERING COEFFICIENTS PER GRAM
C        OF STELLAR MATTER ARE STORED.
C
C        DIMENSIONS NECESSARY
C        AB(NKOMP),ABSK(1),FAKT(NKOMP),FAKTP(IFADIM),NTPO(NTO),PE(NT),PESKAL(1),
C        ROSW(MAX(NL)),SPRID(1),SUMW(NT),T(NT),TSKAL(1),XLA(MAX(NL)),
C        XLA3(MAX(NL))
C        THE DIMENSIONS ARE LOWER LIMITS.
C        DIMENSIONS OF ARRAYS IN COMMONS /CA2/,/CA3/ AND /CFIL/ ARE COMMENTED
C        ON IN SUBROUTINE INABS, THOSE OF ARRAYS IN COMMON /CA4/ IN SUBROUTINE
C        TABS.
C        NKOMP IS THE NUMBER OF 'COMPONENTS'
C        NL(I) IS THE NUMBER OF WAVELENGTHS IN WAVELENGTH SET I
C        NT IS THE NUMBER OF T-PE POINTS SUPPLIED IN TSKAL AND PESKAL
C        NTO IS THE NUMBER OF POINTS IN THOSE SCALES FOR WHICH A DETAILED
C              PRINT-OUT IS WANTED.
      include 'spectrum.inc'
C
C      PARAMETER (KFADIM=4000,IFADIM=1000)
      logical first
      DIMENSION TSKAL(NDP),PESKAL(NDP),ABSK(NDP),SPRID(NDP)
      DIMENSION FAKTP(ifadim)
      DIMENSION SUMW(NDP)
      dimension tioabs(ndp),h2oabs(ndp)
      COMMON/UTPUT/IREAD,IWRIT
      COMMON/CA2/ABKOF(nabdim),KOMPLA(mkomp*20),KOMPR,KOMPS,NKOMP
      COMMON/CA3/ILOGTA(mkomp),NULL
      COMMON/CA4/AFAK(KFADIM),NOFAK(IFADIM),NPLATS(IFADIM)
      COMMON/CA5/AB(mkomp),FAKT(mkomp),PE(NDP),T(NDP),XLA(20),XLA3(20),
     &           RO,
     &           SUMABS,SUMSCA,VIKTR,ISET,NLB
      COMMON/CFIL/IRESET(numbset),ISLASK,IREAT
      COMMON/COUTR/NTO,NTPO(10)
      COMMON/CROS/ROSW(20)
      COMMON /CARC3/ F1P,F3P,F4P,F5P,HNIC,PRESMO(30)
      COMMON /CARC4/ PROV(mkomp),NPROVA,NPROVS,NPROV
      COMMON /TIO/PTIO(NDP),ROsav(NDP),POXG1(NDP)
      COMMON/CI4/ IELEM(16),ION(16,5),TMOLIM,MOLH
      COMMON/CMOL1/EH,FE,FH,FHE,FC,FCE,FN,FNE,FO,FOE,FK,FKE,FS,FSE
      COMMON /DENSTY/ ROTEST(NDP),PRH2O(NDP)
      data first/.true./

      save first
C
C
      if (first) then
        newt=2
        first=.false.
      endif
      ISET=ISETA
      IF(NEWT.GT.1)ISETP=-1
      IF(NEWT.EQ.0)GO TO 5
C
C        FACTORS ONLY DEPENDENT ON T-PE
C
      CALL TABS(NT,TSKAL)
      IFAK=1
      KFAK=1
      JP=0
      KP=1
C
C        LOOP OVER THE T-PE POINTS ('THE FIRST NTP-LOOP')
      DO4 NTP=1,NT
      T(NTP)=TSKAL(NTP)
      PE(NTP)=PESKAL(NTP)
C        IS PRINT-OUT WANTED FOR T-PE POINT NO. NTP
      IOUTR=0
      IF(KP.GT.NTO)GO TO 3
      IF(NTP.EQ.NTPO(KP))GO TO 1
      GO TO 3
    1 IOUTR=1
      KP=KP+1
    3 CONTINUE
C
      CALL JON(T(NTP),PE(NTP),1,PG,RO,DUM,IOUTR,ntp)
cc      print*,'absko back from jon, calling detabs'
      CALL DETABS(J,0,NTP,IOUTR)
cc      print*,'absko back from detabs, nkomp, kompr,komps',
cc     &      nkomp,kompr,komps
C
C        WE STORE THE FAKT ARRAY, MADE IN JON-DETABS IN LONGER ARRAYS NAMELY
C                  IN AFAK FOR TEMPERATURE-INDEPENDENT COMPONENTS
C                  IN FAKTP FOR TEMPERATURE-DEPENDENT ONES
      DO2 KOMP=1,KOMPR
      AFAK(KFAK)=FAKT(KOMP)
cc      print*,'absko fakt(',komp,')',fakt(komp)
    2 KFAK=KFAK+1
      DO4 KOMP=KOMPS,NKOMP
      FAKTP(IFAK)=FAKT(KOMP)
cc      print*,'absko fakt(',komp,')',fakt(komp)
      KFAK=KFAK+NOFAK(IFAK)
    4 IFAK=IFAK+1
C        END OF 'THE FIRST NTP-LOOP'
C
C        READING  OF A NEW WAVELENGTH SET IF INDICATED BY ISET
    5 IF(ISET.EQ.ISETP)GO TO 6
      IREADP=IRESET(ISET)
   51 READ(IREADP,END=52)ISETP,NLB,XLA,XLA3,NABKOF,ABKOF,NKOMPL,KOMPLA
      GO TO 5
   52 REWIND IREADP
      GO TO 51
C        ROSSELAND MEAN OR NOT
    6 IF(J.GT.0)GO TO 9
    7 J1=1
      J2=NLB
      DO8 NTP=1,NT
      SUMW(NTP)=0.
    8 ABSK(NTP)=0.
      GO TO 10
    9 J1=J
      J2=J
C
C        INTERPOLATION IN T
C        LOOP OVER ALL THE WAVELENGTHS IN CASE OF ROSSELAND MEAN. THIS
C        LOOP ENDS IN STATEMENT NO. 26
   10 CONTINUE
      DO26 JP=J1,J2
      KFAK=1
      IFAK=1
      KP=1
C
C        LOOP OVER THE T-PE POINTS ('THE SECOND NTP-LOOP')
      DO26 NTP=1,NT
C
C        IS PRINT-OUT WANTED FOR T-PE POINT NO. NTP
      IOUTR=0
      IF(KP.GT.NTO)GO TO 93
      IF(NTP.EQ.NTPO(KP))GO TO 92
      GO TO 93
   92 IOUTR=1
      KP=KP+1
      IF(KP.EQ.2)IOUTR=2
   93 CONTINUE
      IU=JP
C
C        COMPONENTS WITH ABSORPTION COEFFICIENTS INDEPENDENT OF THE
C        TEMPERATURE
C
      DO14 KOMP=1,KOMPR
      IF(KOMPLA(IU).LE.0)GO TO 12
C        THE VECTOR KOMPLA IS DETERMINED IN SUBROUTINE INABS.
C        KOMPLA GREATER THAN ZERO GIVES THE INDEX IN ABKOF, WHERE THE TABLE FOR
C        THIS COMPONENT AND WAVELENGTH BEGINS.
C        KOMPLA LESS THAN OR EQUAL TO ZERO INDICATES THAT THE ACTUAL ABSORPTION
C        COEFFICIENT FOR THIS COMPONENT AND WAVELENGTH IS ZERO, AS FOUND IN SUB-
C        ROUTINE INABS.
C
   11 INDEX=KOMPLA(IU)
      AB(KOMP)=AFAK(KFAK)*ABKOF(INDEX)
      GO TO 13
   12 AB(KOMP)=0.
   13 KFAK=KFAK+1
   14 IU=IU+NLB
C
C        COMPONENTS WITH T-DEPENDENT ABSORPTION COEFFICIENTS
      DO19 KOMP=KOMPS,NKOMP
      NOP=NOFAK(IFAK)
      IF(NOP.EQ.0)GO TO 17
      IF(KOMPLA(IU).LE.0)GO TO 17
   15 INDEX=NPLATS(IFAK)-1+KOMPLA(IU)
C        THE VECTOR NPLATS IS DETERMINED BY SUBROUTINE TABS. IT GIVES THE ARRAY
C        INDEX OF THE TEMPERATURE AT WHICH THE INTERPOLATION IN ABKOF
C        BEGINS. NOFAK, GIVING INFORMATION ON THE T-INTERPOLATION AND
C        POSSIBLY INDICATING THAT AB=0 (NOFAK=0) IS ALSO DETERMINED BY TABS
C
C        INTERPOLATION
      DELSUM=0.
      DO16 NP=1,NOP
      DELSUM=DELSUM+AFAK(KFAK)*ABKOF(INDEX)
      KFAK=KFAK+1
   16 INDEX=INDEX+1
C
C        HAS THE INTERPOLATION BEEN MADE ON THE LOGARITHM
cc      print*,'absko ifak delsum exp?',ifak,delsum,ilogta(komp)
      IF(ILOGTA(KOMP).GT.0)DELSUM=EXP(DELSUM)
cc      print*,'absko ifak delsum ',ifak,komp,delsum
C        MULTIPLICATION BY FACTOR FROM JON-DETABS
cc      print*,'absko fakt        ',ifak,faktp(ifak)
      DELSUM=DELSUM*FAKTP(IFAK)
cc      print*,'absko fakt*delsum ',ifak,faktp(ifak),delsum
      IF(DELSUM.GE.0.)GO TO 162
C      print*,'osabsko.f faktp(',ifak,')= ',faktp(ifak)
C
C        A NEGATIVE INTERPOLATION RESULT
  161 IF(NULL.GT.0)WRITE(IWRIT,200)KOMP,DELSUM,JP,ISET,T(NTP)
  200 FORMAT(4H AB(,I4,11H) NEGATIVE=,E12.4,5X,17HFOR WAVELENGTH NO,I5,
     *5X,6HSET NO,I5,5X,2HT=,F10.4,'  AND THEREFORE PUT =0 ***ABSKO***')
      AB(KOMP)=0.
      GO TO 18
  162 AB(KOMP)=DELSUM
      GO TO 18
   17 AB(KOMP)=0.
      KFAK=KFAK+NOP
   18 IU=IU+NLB
   19 IFAK=IFAK+1
C
C        WE MULTIPLY BY WAVELENGTH-DEPENDENT  FACTORS AND ADD UP. THIS IS
C        DONE IN DETABS.
cc      print*,'absko, calling detabs 2nd time'
      CALL DETABS(J,JP,NTP,IOUTR)
cc      print*,'absko, back from detabs'
C
      if (J.gt.0) then
        ABSK(NTP)=SUMABS
        SPRID(NTP)=SUMSCA
      else
C
C        SUMMATION TO GET A ROSSELAND MEAN
ccc   25 CONTINUE
C        if(j.le.0) sumabs=sumabs + tioabs(ntp) + h2oabs(ntp)
        IF(J.EQ.0) ABSK(NTP)=ABSK(NTP)+ROSW(JP)*VIKTR/(SUMABS+SUMSCA)
        IF(J.LT.0) ABSK(NTP)=ABSK(NTP)+ROSW(JP)*VIKTR/SUMABS
        SUMW(NTP)=SUMW(NTP)+ROSW(JP)*VIKTR
      endif
   26 CONTINUE
C
C        END OF 'THE SECOND NTP-LOOP'
C
      if (J.le.0) then
        DO NTP=1,NT
          SPRID(NTP)=0.
          ABSK(NTP)=SUMW(NTP)/ABSK(NTP)
        enddo
      endif
C
      RETURN
      END


*
*     ------------------------------------------------------------------
*     H I B P 3 1
*     ------------------------------------------------------------------
*
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
      SUBROUTINE HIBP31(I,BK,IBK,BD,IBD)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/CONSTS/ZERO,TENTH,HALF,ONE,TWO,THREE,FOUR,SEVEN,ELEVEN,EPS
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
      DIMENSION BK(3),BD(3),IBK(7),IBD(7)
      IBK(2)=NJ(I)
      IBD(2)=IBK(2)
      IBK(3)=LJ(I)
      IBD(3)=IBK(3)
      IBK(4)=NOSH1(I)
      IBD(4)=NOSH2(I)
      IBK(5)=J1QN1(I,2)-1
      IBD(5)=J1QN2(I,2)-1
      IBK(6)=J1QN1(I,3)-1
      IBD(6)=J1QN2(I,3)-1
      IREZ=0
      IF(IBK(3).LT.3) THEN
        IBK(7)=2*LJ(I)+1-J1QN1(I,1)
      ELSEIF(IBK(4).LT.3) THEN
        IBK(7)=2*LJ(I)+1-J1QN1(I,1)
      ELSEIF(IBK(4).LT.14) THEN
        IREZ=1
        I2NK=J1QN1(I,1)
        IBK(1)=NUMTERF(I2NK,IBK(6),IBK(5),IBK(4),IBK(7))
      ELSE
        IBK(7)=2*LJ(I)+1-J1QN1(I,1)
      ENDIF
      BK(1)=HALF*DBLE(IBK(7))
      BK(2)=HALF*DBLE(IBK(6))
      BK(3)=-HALF*DBLE(2*LJ(I)+1-NOSH1(I))
      IF(IREZ.EQ.0) THEN
        IBK(1)=NUMTER(IBK(7),IBK(6),IBK(5),IBK(3),IBD(4),IBK(4))
      ENDIF
      IREZ=0
      IF(IBD(3).LT.3) THEN
        IBD(7)=2*LJ(I)+1-J1QN2(I,1)
      ELSEIF(IBD(4).LT.3) THEN
        IBD(7)=2*LJ(I)+1-J1QN2(I,1)
      ELSEIF(IBD(4).LT.14) THEN
        IREZ=1
        I2ND=J1QN2(I,1)
        IBD(1)=NUMTERF(I2ND,IBD(6),IBD(5),IBD(4),IBD(7))
      ELSE
        IBD(7)=2*LJ(I)+1-J1QN2(I,1)
      ENDIF
      BD(1)=HALF*DBLE(IBD(7))
      BD(2)=HALF*DBLE(IBD(6))
      BD(3)=-HALF*DBLE(2*LJ(I)+1-NOSH2(I))
      IF(IREZ.EQ.0) THEN
        IBD(1)=NUMTER(IBD(7),IBD(6),IBD(5),IBD(3),IBK(4),IBD(4))
      ENDIF
      RETURN
      END


Module Forecast
  USE ModuleDefs

  Type DailyWeatherType
    INTEGER YRDOY
    REAL RAIN, SRAD, TMAX, TMIN, PAR
    REAL DCO2, OZON7, RHUM, TDEW, VAPR, WINDSP
  End Type
  TYPE (DailyWeatherType), Allocatable :: Obs_data(:)

  INTEGER FCOUNT, FODAT, FSTART

! Track years of ensemble weather data
  INTEGER EnsYearFirst, EnsYearLast, EnsYearCurrent, ForecastYear

CONTAINS

!========================================================================
! Subroutine FCAST_STORE

! Determine start and end of forecast season (i.e., prior to ensemble)
!   and the first and last years for the historical ensemble weather years
! Store the forecast year weather data plus data from short term forecast file.
!   These will be used in every year of the forecast ensemble.

SUBROUTINE FCAST_STORE(                                 &
     CCO2, DCO2, FILEW, FILEWC, FILEWG, FILEWW,         &  !Output
     FYRDOY, FYRSIM, MEWTH, OZON7, PATHWTC, PATHWTG,    &  !Output
     PATHWTW,REFHT, RHUM, RSEED1, TAMP, TAV, TDEW,      &  !Output
     VAPR, WINDHT, WINDSP, XELEV, XLAT, XLONG, YREND)      !Output

  USE ModuleData
  IMPLICIT NONE

  CHARACTER*1  MEWTH
  CHARACTER*6, PARAMETER :: ERRKEY = "FORCST"
  CHARACTER*12 FILEW, FILEWC, FILEWG
  CHARACTER*78 MSG(2)
  CHARACTER*80 PATHWTC, PATHWTG, PATHWTW
  CHARACTER*92 FILEWW

  INTEGER DOY, I, Obs_YRDOY, RSEED1, YREND, YR, YRSIM
  INTEGER INCDAT, TIMDIF, FYRDOY, FYRSIM
  REAL CCO2, DCO2, OZON7, PAR, RAIN, REFHT, RHUM
  REAL SRAD, TAMP, TAV, TDEW, TMAX, TMIN, VAPR, WINDHT
  REAL WINDSP, XELEV, XLAT, XLONG
  TYPE (ControlType) CONTROL, CONTROL2

  EXTERNAL IPWTH, YR_DOY

  CALL GET(CONTROL)
  FODAT = CONTROL % FODAT
  YRSIM = CONTROL % YRSIM
  CALL YR_DOY(YRSIM,YR,DOY)

! ----------------------------------------------------------------------
  SELECT CASE (CONTROL % ENDYRS)
! ----------------------------------------------------------------------
  CASE (1)
!   ENDYRS = 1: Initialize and store forecast data

!   FODAT = date of forecast. Weather prior to this date come from observations.
!     On this date and after, they come from ensemble.
!   FCOUNT = number of days of "observed weather" to be used in forecast.
    FSTART = YRSIM
    FCOUNT = TIMDIF(FSTART, FODAT)

!   Initialize weather file for this year's data (i.e., pre-forecast date)
    CONTROL2 = CONTROL
    CONTROL2 % DYNAMIC = SEASINIT
    Obs_YRDOY = INCDAT(FSTART, -1)
    CONTROL2 % YRDOY = Obs_YRDOY

!   Determine the first and last years of the weather ensemble using simulation start date as the reference.
!   These physical years are needed for historical ensemble, but not for generated weather
!   First year of historical ensemble is NYRS before start of simulation date
    EnsYearFirst = YR - CONTROL % NYRS
!   Last year of historical ensemble is one year before start of simulation date
    EnsYearLast = YR - 1
!   Start with first year of ensemble
    EnsYearCurrent = EnsYearFirst
    FYRDOY = EnsYearFirst *1000 + DOY
    FYRSIM = FYRDOY
    ForecastYear = YR

!   IF FODAT is before or equal to YRSIM, then all weather data are from ensembles.
    IF (FCOUNT .LT. 1) RETURN

    IF (ALLOCATED(Obs_data)) THEN
      DEALLOCATE(Obs_data)
    ENDIF

!   Allocate the array size for observed weather data
    Allocate (Obs_data(0:FCOUNT))

    Obs_data % YRDOY  = -99
    Obs_data % RAIN   = -99.
    Obs_data % SRAD   = -99.
    Obs_data % TMAX   = -99.
    Obs_data % TMIN   = -99.
    Obs_data % PAR    = -99.
    Obs_data % DCO2   = -99.
    Obs_data % OZON7  = -99.
    Obs_data % RHUM   = -99.
    Obs_data % TDEW   = -99.
    Obs_data % VAPR   = -99.
    Obs_data % WINDSP = -99.

! ----------------------------------------------------------------------
!   Initialize IPWTH for forecast year
    CALL IPWTH(CONTROL2, ERRKEY,                        &
        CCO2, DCO2, FILEW, FILEWC, FILEWG, FILEWW,    &    !Output
        MEWTH, OZON7, PAR,                            &    !Output
        PATHWTC, PATHWTG, PATHWTW,                    &    !Output
        RAIN, REFHT, RHUM, RSEED1, SRAD,              &    !Output
        TAMP, TAV, TDEW, TMAX, TMIN, VAPR, WINDHT,    &    !Output
        WINDSP, XELEV, XLAT, XLONG, YREND,            &    !Output
        SEASINIT)

!   FCAST_ScanWeathData was called from IPWTH so now we know
!   the starting and ending dates for weather in a long weather file.
!   Could do some checking here.

    IF (YREND .EQ. Obs_YRDOY) THEN
      MSG(1) = "In-season observed weather data not found."
      MSG(2) = "Program will stop."
      CALL WARNING(2, ERRKEY, MSG)
      CALL ERROR(ERRKEY,CONTROL%ERRCODE,"",0)
    ENDIF

    Obs_data(0) % YRDOY  = Obs_YRDOY
    Obs_data(0) % SRAD   = SRAD
    Obs_data(0) % TMAX   = TMAX
    Obs_data(0) % TMIN   = TMIN
    Obs_data(0) % RAIN   = RAIN
    Obs_data(0) % PAR    = PAR
    Obs_data(0) % TDEW   = TDEW
    Obs_data(0) % WINDSP = WINDSP
    Obs_data(0) % RHUM   = RHUM
    Obs_data(0) % VAPR   = VAPR
    Obs_data(0) % DCO2   = DCO2
    Obs_data(0) % OZON7  = OZON7

! ----------------------------------------------------------------------
!   Get and store weather data between YRSIM and FODAT-1
    CONTROL2 = CONTROL
    CONTROL2 % DYNAMIC = RATE

!   IPWTH was already initialized for the forecast year. Go ahead and retrieve
!     data for this year and store for retrieval at the beginning of each
!     ensemble.
    DO I = 1, FCOUNT
      Obs_YRDOY = INCDAT(FSTART, I-1)
      CONTROL2 % YRDOY = Obs_YRDOY

      CALL IPWTH(CONTROL2, ERRKEY,                      &
          CCO2, DCO2, FILEW, FILEWC, FILEWG, FILEWW,    &    !Output
          MEWTH, OZON7, PAR,                            &    !Output
          PATHWTC, PATHWTG, PATHWTW,                    &    !Output
          RAIN, REFHT, RHUM, RSEED1, SRAD,              &    !Output
          TAMP, TAV, TDEW, TMAX, TMIN, VAPR, WINDHT,    &    !Output
          WINDSP, XELEV, XLAT, XLONG, YREND,            &    !Output
          RATE)

      Obs_data(I) % YRDOY  = Obs_YRDOY
      Obs_data(I) % SRAD   = SRAD
      Obs_data(I) % TMAX   = TMAX
      Obs_data(I) % TMIN   = TMIN
      Obs_data(I) % RAIN   = RAIN
      Obs_data(I) % PAR    = PAR
      Obs_data(I) % TDEW   = TDEW
      Obs_data(I) % WINDSP = WINDSP
      Obs_data(I) % RHUM   = RHUM
      Obs_data(I) % VAPR   = VAPR
      Obs_data(I) % DCO2   = DCO2
      Obs_data(I) % OZON7  = OZON7
    ENDDO

! ----------------------------------------------------------------------
  CASE DEFAULT  ! CONTROL % ENDYRS > 1
!   Data has already been stored. Just need to update YRSIM for this ensemble year
    EnsYearCurrent = EnsYearCurrent + 1
    FYRDOY = EnsYearCurrent * 1000 + DOY
    FYRSIM = FYRDOY
    RETURN
  END SELECT

  RETURN
END SUBROUTINE FCAST_STORE

!========================================================================
SUBROUTINE FCAST_RETRIEVE(WDATE,        &   !Input
        DCO2, FYRDOY, OZON7, PAR, RAIN, &   !Output
        RHUM, TDEW, TMAX, TMIN, VAPR,   &   !Output
        SRAD, WINDSP)                       !Output

  USE ModuleData
  CHARACTER*6, PARAMETER :: ERRKEY = "FORCST"
  CHARACTER*78 MSG(4)
  INTEGER DOY, YR, FYRDOY
  INTEGER WDATE, I, TIMDIF
  REAL RAIN, TMAX, TMIN, SRAD, PAR
  REAL DCO2, OZON7, RHUM, TDEW, VAPR, WINDSP
  TYPE (ControlType) CONTROL
  EXTERNAL :: YR_DOY, TIMDIF

! FYRDOY = 0 - Use observed data (retrieve from array below).
! FYRDOY > 0 - This is the date to use for the historical ensemble.

! Current date is after forecast date, use ensemble weather data
  IF (WDATE .GE. FODAT .OR. FCOUNT .LT. 1) THEN
    CALL GET(CONTROL)
    CALL YR_DOY(WDATE, YR, DOY)
    EnsYearCurrent = EnsYearFirst + CONTROL % ENDYRS - 1
    FYRDOY = EnsYearCurrent * 1000 + DOY

  ELSE
!   Use observed weather data.
    I = TIMDIF(FSTART, WDATE) + 1
    IF (WDATE .NE. Obs_data(I) % YRDOY) THEN
      WRITE(MSG(1),'(A)') "Error in forecast weather data, possible non-consecutive dates."
      WRITE(MSG(2),'(A,I10)') "Simulation date:", WDATE
      WRITE(MSG(3),'(A,I10)') "Observed weather date:", Obs_data(I) % YRDOY
      WRITE(MSG(4),'(A)') "Program will stop."
      CALL WARNING(4, ERRKEY, MSG)
      CALL ERROR(ERRKEY,CONTROL%ERRCODE,"",0)
    ENDIF

    RAIN   = Obs_data(I) % RAIN
    SRAD   = Obs_data(I) % SRAD
    TMAX   = Obs_data(I) % TMAX
    TMIN   = Obs_data(I) % TMIN
    PAR    = Obs_data(I) % PAR
    TDEW   = Obs_data(I) % TDEW
    WINDSP = Obs_data(I) % WINDSP
    RHUM   = Obs_data(I) % RHUM
    VAPR   = Obs_data(I) % VAPR
    DCO2   = Obs_data(I) % DCO2
    OZON7  = Obs_data(I) % OZON7
    FYRDOY = 0
  ENDIF

  RETURN
END SUBROUTINE FCAST_RETRIEVE

!========================================================================
SUBROUTINE FCAST_FINISH()
  IF (ALLOCATED(Obs_data)) THEN
    DEALLOCATE(Obs_data)
  ENDIF
  RETURN
END SUBROUTINE FCAST_FINISH

!========================================================================
SUBROUTINE FCAST_ScanWeathData(CONTROL, FileW, LunWth, CenturyFirst)

!Scan the historic weather data to get starting and ending dates.
!Set the Century for the first weather data - important for 2-digit years.

  USE ModuleDefs
  CHARACTER*92 FileW
  CHARACTER*120 LINE
  Integer ERR, ErrCode, ISECT, LINWTH, LUNWTH
  integer CenturyForecast, CenturyFirst, I, NYears, NDays, NRecords
  integer WRecDate, WeathRecFirst, WeathRecLast, WFirstDate, WFirstYear, WLastYear, WLastDOY
  REAL NWeathYears
  Type (ControlType) CONTROL
  INTEGER :: INCDAT  !FUNCTION

  ErrCode = 0

  OPEN (LUNWTH,FILE=FILEW,STATUS='OLD',IOSTAT=ERR)
  REWIND(LUNWTH)
  IF (ERR /= 0) THEN
    ErrCode = 29
    CALL WeatherError(CONTROL, ErrCode, FILEW, 0, 0, 0)
    RETURN
  ENDIF

! Find 2nd header line
  DO I = 1, 2
! Look for header line beginning with '@' in column 1 (ISECT = 3)
    DO WHILE (.TRUE.)   !.NOT. EOF(LUNWTH)
      CALL IGNORE2 (LUNWTH, LINWTH, ISECT, LINE)
      SELECT CASE(ISECT)
        CASE(0);            !End of file
          ErrCode = 59
          CALL WeatherError(CONTROL, ErrCode, FILEW, 0, 0, 0)
          RETURN
        CASE(1); CYCLE      !Data line
        CASE(2); CYCLE      !New section ("*" found)
        CASE(3); EXIT       !Header line ("@" found)
      END SELECT
    ENDDO  !Loop thru data file one record at a time
  ENDDO    !Loop thru 1st and 2nd headers

  I = 0
! Read weather dates
  DO WHILE (.TRUE.)   !.NOT. EOF(LUNWTH)
    CALL IGNORE2 (LUNWTH, LINWTH, ISECT, LINE)
    SELECT CASE(ISECT)
      CASE(0); EXIT       !End of file
      CASE(2); EXIT       !New section ("*" found)
      CASE(3); EXIT       !Header line ("@" found)
      CASE(1)             !Data line found
        I = I + 1
        READ (LINE,'(I7)') WRecDate
        IF (I .EQ. 1) WeathRecFirst = WRecDate
    END SELECT
  ENDDO  !Loop thru data file one record at a time

  WeathRecLast = WRecDate
  NRecords = I
  NWeathYears = NRecords / 365.25

  IF (WeathRecLast .LE. 99365) THEN
!   2-digit years, calculate first weather date based on FODAT and # records
!   First assume last weather record has the same century as the FODAT
    CenturyForecast = AINT(FLOAT(FODAT) / 100000.)
    WeathRecLast = CenturyForecast * 100000 + WeathRecLast
!   If the last weather date is before FODAT, then need to incrment the century
    DO WHILE (WeathRecLast .LT. FODAT)
      WeathRecLast = WeathRecLast + 100000
    ENDDO

!   Now we have the correct century for the last weather date,
!     calculate first weather date based on number of records
    CALL YR_DOY(WeathRecLast, WLastYear, WLastDOY)
    NYears = AINT(NWeathYears)
    NDays = (NWeathYears - NYears)*365.25
    WFirstYear = WLastYear - NYears

    WFirstDate = WFirstYear * 1000 + WLastDOY
    WFirstDate = INCDAT(WFirstDate, -Ndays+1)

!   One possible failure mode is when the first weather date is near
!   the beginning or end of a century. Because the number of leap days
!   is uncertain, there may be a mismatch on first date and therefore
!   first century. Probably need to check the DOY. If it matches, then
!   we're OK. If not, then maybe adjust WFirstDate to match WeathRecFirst
!   Below is the beginning of something to handle that.
!    CALL YR_DOY(WeathRecFirst, YR0, DOY0)
!    CALL YR_DOY(WFirstDate, YR1, DOY1)
!    IF (DOY1 - DOY0 .GT. 300) THEN

  ENDIF

  CenturyFirst = AINT(FLOAT(WFirstDate) / 100000.)

  CLOSE (LUNWTH)
  RETURN
END SUBROUTINE FCAST_ScanWeathData

!========================================================================
End Module Forecast
!========================================================================


	PROGRAM CSP_GALAXEV

!	Computes spectral energy distribution as a function of time for a
!	Composite Stellar Population (CSP) by performing a convolution integral
!	of the spectral energy distributions for a Single Stellar Population SSP
!	with the chosen Star Formation Rate (SFR).

!	Modified in Toulouse: 6/8/97 to include both convolution of sed and spectral indices

!	Array declarations
	parameter (jb=10)
	include 'csp.dec'
	character ans,name*256,save*256,aux*512,atlas
	logical stelib
	real w(imw),h(imw)
	real tauv,mu_d,tv,fext,fi(40),fc(40)
	real snr(0:jts),pnr(0:jts), bh(0:jts), sn(0:jts), wd(0:jts), rm(0:jts)
	real bol(0:jts),str(0:jts), sf(0:jts),evf(0:jts),gas(0:jts),gal(0:jts),xml(0:jts),xdp(0:jts)
	real fxu(0:jts),fxg(0:jts),fxr(0:jts),fxi(0:jts),fxz(0:jts),fxk(0:jts)
	real ufwa,gfwa,rfwa,ifwa,zfwa,kfwa,ufwla,gfwla,rfwla,ifwla,zfwla,kfwla,mwa,mwla
	common /w_ages/ fxu,fxg,fxr,fxi,fxz,fxk,ufwa,gfwa,rfwa,ifwa,zfwa,kfwa,ufwla,gfwla,rfwla,ifwla,zfwla,kfwla,mwa,mwla
	data ihrd/0/,atlas/' '/

!	Check if correct filter file is in use.
	j=ifilter()
	if (j.eq.0) then
		write (6,'(2a)') char(7),'Please assign correct filter file'
		write (6,'(2a)') char(7),'Use command: stdfilt'
		stop
	endif

!	Ask for file name
	save='_'
1	call copyright(6)
2	l=margo(save)
	write (6,'(x,3a,$)') 'BC_GALAXEV SSP sed in file [',save(1:l),'] = '
	read (5,'(a)',end=10) name
	if (largo(name).eq.0) then
		name=save
	else
!		Check if interpolation in metallicity of SSP is requested
		call interpolate_ssp(name)
	endif
	call s500('k','',5.)
	call chaext(name,'ised',mm)
	iread=0
	if (name.ne.save) iread=1
!	lr=index(name,'_lr_')
	open (1,file=name,form='unformatted',status='old',err=3)
	close (1)
	jdef=jjdef(name)

!       Ask for dust attenuation parameters
        write (6,'(/x,a,$)')   'Include attenuation by dust? Y/[N] '
        read (5,'(a)',end=10) ans
        if (ans.ne.'y'.and.ans.ne.'Y') then
           tauv=0.
	   mu_d=0.
        else
13         write (6,'(/x,a)')     '[using simple 2-component model of Charlot & Fall (2000)]'
           write (6,'(x,a,$)') 'Enter total effective attenuation optical depth: tau_V [1.0] = '
!          read (5,'(f10.0)',err=13,end=10) tauv
           read (5,'(a)',end=10) aux
	   if (largo(aux).eq.0) then
                tauv=1.
           else
                read (aux,*,err=13) tauv
           endif
14         write (6,'(x,a,$)') 'Enter fraction of tau_V arising from the ambient ISM: mu [0.3] = '
!          read (5,'(f10.0)',err=14,end=10) mu_d
	   read (5,'(a)',end=10) aux
           if (largo(aux).eq.0) then
                mu_d=0.3
           else
                read (aux,*,err=14) mu_d
           endif
	   write (6,'(x,a,f7.4)') '...using tau_V = ',tauv
	   write (6,'(x,a,f7.4)') '            mu = ',mu_d
        endif
!	write (501,*) tauv,mu_d
	call s500('f','',tauv)
	call s500('f','',mu_d)

!	Open input sed file (read again, tb modified in case of truncated SFR)
!	if (iread.ne.0) then
	   save=name
	   close (1)

!	   Check length of records (needed in Linux)
	   open (1,file=name,form='unformatted',status='old',err=3)
	   read (1)
	   read (1)
	   read (1,err=55) inl,(h(i),i=1,inl),inx
!	   write (6,*) inl,inx
	   imx=1
	   goto 56
55	   imx=0
56	   close (1)
	   open (1,file=name,form='unformatted',status='old',err=3)
!	   Read basic parameters from SSP input file
	   read (1) nsteps,(tb(i),i=0,nsteps-1),ml,mu,iseg,(xx(i),lm(i),um(i),baux(i),cn(i),cc(i),i=1,iseg),totm,totn,avs,jo,tauo,id,tcut,ttt,ttt,ttt,id,id,igw,stelib

	   if (jo.ne.0) then
	      write (6,'(x,a$)')'File does not contain an SSP. Proceed Y/[N] ? '
	      read (5,'(a)',end=10) ans
	      if (ans.ne.'y'.and.ans.ne.'Y') goto 1
	   endif
!	   Read sed from SSP file
	   write (6,'(2a)') ' Reading file ',name
	   read (1) inl,(w(i),i=1,inl)
	   do n=0,nsteps-1
	   if (imx.gt.0) then
		read (1) inl,(fl(i,n),i=1,inl),inx,(fl(i,n),i=inl+1,inl+inx)
	   else
		read (1) inl,(fl(i,n),i=1,inl)
		inx=0
	   endif
!          Attenuate by dust if requested (use Charlot & Fall, 2000, ApJ, 539, 718)
           if (tauv.gt.0.) then
              if (tb(n).le.1.e7) then
                 tv=tauv
              else
                 tv=mu_d*tauv
              endif
              do i=1,inl
                fl(i,n)=fl(i,n)*fext(w(i),tv)
              enddo
           endif
	   enddo
	   inw=inl+inx
	   write (6,*) inl,' wavelength points per record'
	   write (6,*) inx,' spectral index points per record'
	   write (6,*) inw,' total points per record'
	   write (6,*) nsteps,' time steps'
	   read (1,end=4) nsteps,(bflx(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(strm(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(sf(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(evfl(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(snbr(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(pnbr(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(bhtn(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(sntn(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(wdtn(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(rmtm(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(toff(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(bolms(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(gasms(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(galms(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(rml(i),i=0,nsteps-1)
	   read (1,end=4) nsteps,(rdp(i),i=0,nsteps-1)
4	   close (1)

!	   Store flux in the u, g, r, i, z, and K bands for each SSP age in order
!	   to compute the flux weighted age of the composite population.
!		filter = 120 SDSS Camera u Response Function, airmass = 1.3 (June 2001)
!		filter = 121 SDSS Camera g Response Function, airmass = 1.3 (June 2001)
!		filter = 122 SDSS Camera r Response Function, airmass = 1.3 (June 2001)
!		filter = 123 SDSS Camera i Response Function, airmass = 1.3 (June 2001)
!		filter = 124 SDSS Camera z Response Function, airmass = 1.3 (June 2001)
!		filter =  57 IR K filter + Palomar 200 IR detectors + atmosphere.57
5	   write (6,'(/x,a,$)') 'Compute flux weighted age in the galaxy rest frame at z [0] = '
	   read (5,'(f12.0)',err=5,end=10) z
!	   read (5,*,err=5,end=10) z
	   do n=0,nsteps-1
	   do i=1,inl
	   h(i)=fl(i,n)
	   enddo
!	   In the observer frame use the value of z entered above
!	   zu = z
!	   In the galaxy restframe (as needed for Alfredo's JPAS fits) use z = 0
	   zu = 0.
	   fxu(n) = filter_n(120,w,h,inl,zu,kerr)
	   fxg(n) = filter_n(121,w,h,inl,zu,kerr)
	   fxr(n) = filter_n(122,w,h,inl,zu,kerr)
	   fxi(n) = filter_n(123,w,h,inl,zu,kerr)
	   fxz(n) = filter_n(124,w,h,inl,zu,kerr)
	   fxk(n) = filter_n( 57,w,h,inl,zu,kerr)
	   enddo

!	endif

!	Ask for SFR
	call sfr_0_b(1,z)

!	Expand time scale if required
!	if ((io.ne.2.and.tcut.lt.20.E9).or.(io.eq.2.and.tcut.gt.2.E9)) call expand_time_steps
	if ((io.ne.2.and.tcut.lt.20.E9).or.(io.eq.2                 )) call expand_time_steps
	if (io.eq.7) call add_time_steps

!	Ask for output file name. Open files.
!	Write time scale, IMF, and wavelength scale in output file
	lun=-1
	ioption=99
	call name_sed(lun,jun,kdist,ihrd,ioption,jdef,ldef,ml,mu,name,atlas)

!	Compute convolution integral, rest frame colors, and write results for CSP
	if (isingle == 0) then
!		Use for standard csp models
		nstart = 0
		nfinal = nsteps-1
		write (lun) nsteps,(tb(i),i=0,nsteps-1),ml,mu,iseg,(xx(i),lm(i),um(i),baux(i),cn(i),cc(i),i=1,iseg),totm,totn,avs,io,tau,id,tau,tau,1.,1.,id,id,igw,stelib
	else
!		Use for Chen et al. SFH model
		call s500('r',name,0.)
		nfinal=kfinal(tsng)
		nstart = nfinal
		write (lun) 1,tb(nfinal),ml,mu,iseg,(xx(i),lm(i),um(i),baux(i),cn(i),cc(i),i=1,iseg),totm,totn,avs,io,tau,id,tau,tau,1.,1.,id,id,igw,stelib
!		do i=0,nsteps-1
!		if (tb(i) <= tauf) then
!			nfinal = i
!		endif
!		enddo
!		Refine position of age tb(i) closest to tauf
!		if (abs(tb(nfinal+1)-tauf) < abs(tb(nfinal)-tauf)) nfinal=nfinal+1
	endif
	write (lun) inl,(w(i),i=1,inl)
	do n=nstart,nfinal
	if (io.gt.0) then
		call convolve_new(h,n,bol(n),str(n),evf(n),snr(n),pnr(n),bh(n),sn(n),wd(n),rm(n),gas(n),gal(n),xml(n),xdp(n))
		call file_w_ages(io,name,zu,tb(n),w,h,inl,ufwa,gfwa,rfwa,ifwa,zfwa,kfwa,mwa,ufwla,gfwla,rfwla,ifwla,zfwla,kfwla,mwla)
	else
		do i=1,inl+inx
		h(i)=fl(i,n)
		enddo
		bol(n)=bflx(n)
		str(n)=strm(n)
	   	evf(n)=evfl(n)
	   	snr(n)=snbr(n)
	   	pnr(n)=pnbr(n)
	   	 bh(n)=bhtn(n)
	   	 sn(n)=sntn(n)
	   	 wd(n)=wdtn(n)
	   	 rm(n)=rmtm(n)
	   	gas(n)=gasms(n)
	   	gal(n)=galms(n)
		xml(n)=rml(n)
		xdp(n)=rdp(n)
	endif
!	Compute galaxy mass
	do i=1,n
	sf(n)=sfr(tb(n))
	enddo
	galmass=gal_mass(io,tb(n),sf(n))

!	Store sed. Report standard colors and Guy Worthey Spectral indices
	if (isingle == 0 .or. n == nfinal) then
		write (lun) inl,(h(i),i=1,inl),inx,(h(i),i=inl+1,inl+inx)
		call rf_color(io,tb(n),w,h,inl,lun,bol(n),str(n),sf(n),evf(n),snr(n),pnr(n),bh(n),sn(n),wd(n),rm(n),toff(n),bolms(n),gas(n),gal(n),xml(n),xdp(n))
!		Guy Worthey Spectral indices
		inx2=inx/2
		do i=1,inx2
		fi(i)=h(inl+i)
		fc(i)=h(inl+inx2+i)
		enddo
		igw=0
		call gw_indices(tb(n),fi,fc,lun,igw)
	endif

!	Report percent done
	if (n.gt.1) call percent(6,n,nfinal,'CSP_GALAXEV ' // name(1:nargo(name)))
	enddo

!	Add time behaviour of various quantities
	if (isingle == 0) then
		write (lun) nsteps,(  bol(i),i=0,nsteps-1)
		write (lun) nsteps,(  str(i),i=0,nsteps-1)
		write (lun) nsteps,(   sf(i),i=0,nsteps-1)
		write (lun) nsteps,(  evf(i),i=0,nsteps-1)
		write (lun) nsteps,(  snr(i),i=0,nsteps-1)
		write (lun) nsteps,(  pnr(i),i=0,nsteps-1)
		write (lun) nsteps,(   bh(i),i=0,nsteps-1)
		write (lun) nsteps,(   sn(i),i=0,nsteps-1)
		write (lun) nsteps,(   wd(i),i=0,nsteps-1)
		write (lun) nsteps,(   rm(i),i=0,nsteps-1)
		write (lun) nsteps,( toff(i),i=0,nsteps-1)
		write (lun) nsteps,(bolms(i),i=0,nsteps-1)
		write (lun) nsteps,(  gas(i),i=0,nsteps-1)
		write (lun) nsteps,(  gal(i),i=0,nsteps-1)
		write (lun) nsteps,(  xml(i),i=0,nsteps-1)
		write (lun) nsteps,(  xdp(i),i=0,nsteps-1)
	endif

!	Write command file to delete unwnated files
	call delete_files(name,inl,1)
	call file_w_ages(-1,name,zu,tb(n),w,h,inl,ufwa,gfwa,rfwa,ifwa,zfwa,kfwa,mwa,ufwla,gfwla,rfwla,ifwla,zfwla,kfwla,mwla)
	goto 1

3	write (6,'(x,5a)') char(7),'File ',name(1:largo(name)),' not found',char(7)
	goto 2
10	end

        REAL FUNCTION FEXT(X,TV)
        real x,tv,tau

        fext=1.

        if (tv.eq.0.) return

        tau=tv*( (5500./x)**0.7 )
        fext=exp(-tau)

        return
        end


! Copyright (c) 2018-2019 Etienne Descamps
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification,
! are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
!    this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
!    this list of conditions and the following disclaimer in the documentation and/or
!    other materials provided with the distribution.
!
! 3. Neither the name of the copyright holder nor the names of its contributors may be
!    used to endorse or promote products derived from this software without specific prior
!    written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
! ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
! WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
! IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
! INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
! (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
! LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
! EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Module mlf_supervised_model
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_intf
  Use mlf_errors
  Use mlf_rand
  Use mlf_rsc_array
  Use mlf_models
  Use mlf_step_algo
  Use mlf_fun_intf
  Use mlf_utils
  IMPLICIT NONE
  PRIVATE

  Type, Public :: mlf_model_parameters
  End Type mlf_model_parameters

  Type, Public, Abstract, Extends(mlf_model_parameters) :: mlf_model_real_parameters
  Contains
    procedure(mlf_real_get_nparameters), deferred :: getNParameters
    procedure(mlf_real_parameters_set), deferred :: set
  End Type mlf_model_real_parameters

  Type, Public :: mlf_model_experiment
  End Type mlf_model_experiment

  Type, Public :: mlf_model_result
  End Type mlf_model_result

  Type, Public, Abstract, Extends(mlf_model_result) :: mlf_result_vectReal
  Contains
    procedure(mlf_vectResults), deferred :: vectResults
    procedure(mlf_real_get_noutput), deferred :: getNOutput
  End Type mlf_result_vectReal

  Type, Public, Abstract, Extends(mlf_step_obj) :: mlf_experience_model
  Contains
    procedure(mlf_model_setupModel), deferred :: setupModel
    procedure :: getResults => mlf_experience_dummy_results
    procedure :: getNCstr => mlf_experience_dummy_getNCstr
  End Type mlf_experience_model

  Type, Public :: mlf_data_point
    class(mlf_model_experiment), allocatable :: experiment
    class(mlf_model_result), allocatable :: results
    real(c_double) :: weight = 1d0
  End Type mlf_data_point

  Type, Public, Abstract, Extends(mlf_obj) :: mlf_experience_runner
  Contains
    procedure(mlf_experience_run), deferred :: runExp
  End Type mlf_experience_runner

  Type, Public, Bind(C) :: mlf_local_experience_stats
    integer(c_int64_t) :: clock_launched
    integer(c_int) :: dataSet, paramSet, nR, state
  End Type mlf_local_experience_stats

  Integer(c_int), Public, Parameter :: mlf_exp_stat_waiting = 0, mlf_exp_stat_running = 1, &
    mlf_exp_stat_finished = 2

  Type, Public, Extends(mlf_experience_runner) :: mlf_local_experience_runner
    class(mlf_experience_model), allocatable :: model
    class(mlf_model_real_parameters), allocatable :: params
    class(mlf_result_vectReal), allocatable :: results
    type(mlf_local_experience_stats), pointer :: stats => NULL()
  Contains
    procedure :: runExp => mlf_local_runExp
    procedure :: statSetPoint => mlf_local_statSetPoint
    procedure :: statStart => mlf_local_statStart
    procedure :: statFinished => mlf_local_statFinished
  End Type mlf_local_experience_runner

  Type, Public, Abstract :: mlf_local_initializer
  Contains
    procedure(mlf_local_init_runner), deferred :: init_runner
  End Type mlf_local_initializer

  Abstract Interface
    Integer Function mlf_vectResults(this, Y)
      Use iso_c_binding
      import :: mlf_result_vectReal
      class(mlf_result_vectReal), intent(in), target :: this
      real(c_double), intent(out) :: Y(:)
    End Function mlf_vectResults

    Integer Function mlf_experience_run(this, experiment, X, Y, Cstr)
      Use iso_c_binding
      import :: mlf_experience_runner, mlf_model_experiment
      class(mlf_experience_runner), intent(inout), target :: this
      class(mlf_model_experiment), intent(in), target :: experiment
      real(c_double), intent(in) :: X(:)
      real(c_double), intent(out) :: Y(:), Cstr(:)
    End Function mlf_experience_run

    Subroutine mlf_real_get_nparameters(this, nPar, nCstr)
      import :: mlf_model_real_parameters
      class(mlf_model_real_parameters), intent(in), target :: this
      integer, intent(out) :: nPar, nCstr
    End Subroutine mlf_real_get_nparameters

    Integer Function mlf_real_get_noutput(this)
      import :: mlf_result_vectReal
      class(mlf_result_vectReal), intent(in), target :: this
    End Function mlf_real_get_noutput

    Integer Function mlf_real_parameters_set(this, X, Cstr)
      Use iso_c_binding
      import :: mlf_model_real_parameters
      class(mlf_model_real_parameters), intent(inout), target :: this
      real(c_double), intent(in) :: X(:)
      real(c_double), intent(out), optional :: Cstr(:)
    End Function mlf_real_parameters_set

    Integer Function mlf_model_setupModel(this, param, experiment)
      import :: mlf_experience_model, mlf_model_experiment, mlf_model_parameters
      class(mlf_experience_model), intent(inout), target :: this
      class(mlf_model_parameters), intent(in) :: param
      class(mlf_model_experiment), intent(in) :: experiment
    End Function mlf_model_setupModel

    Integer Function mlf_local_init_runner(this, runner)
      import :: mlf_local_initializer, mlf_local_experience_runner
      class(mlf_local_initializer), intent(inout) :: this
      class(mlf_local_experience_runner), intent(inout) :: runner
    End Function mlf_local_init_runner
  End Interface
Contains
  Integer Function mlf_experience_dummy_results(this, results, Cstr) Result(info)
    class(mlf_experience_model), intent(inout), target :: this
    class(mlf_model_result), intent(inout) :: results
    real(c_double), intent(out), optional :: Cstr(:)
    info = -1 ! You shall reimplement this function to get results
  End Function mlf_experience_dummy_results

  Integer Function mlf_experience_dummy_getNCstr(this) Result(N)
    class(mlf_experience_model), intent(in) :: this
    N = 0
  End Function mlf_experience_dummy_getNCstr

  Subroutine mlf_local_statSetPoint(this, dataSet, paramSet)
    class(mlf_local_experience_runner), intent(inout) :: this
    integer, intent(in) :: dataSet, paramSet
    If(.NOT. ASSOCIATED(this%stats)) RETURN
    this%stats%dataSet = dataSet
    this%stats%paramSet = paramSet
    this%stats%nR = 0
    this%stats%state = mlf_exp_stat_waiting
  End Subroutine mlf_local_statSetPoint

  Subroutine mlf_local_statStart(this)
    class(mlf_local_experience_runner), intent(inout) :: this
    If(.NOT. ASSOCIATED(this%stats)) RETURN
    this%stats%state = mlf_exp_stat_running
    this%stats%nR = this%stats%nR + 1
    CALL SYSTEM_CLOCK(this%stats%clock_launched)
  End Subroutine mlf_local_statStart

  Subroutine mlf_local_statFinished(this)
    class(mlf_local_experience_runner), intent(inout) :: this
    If(.NOT. ASSOCIATED(this%stats)) RETURN
    this%stats%state = mlf_exp_stat_finished
  End Subroutine mlf_local_statFinished

  Integer Function mlf_local_runExp(this, experiment, X, Y, Cstr) Result(info)
    class(mlf_local_experience_runner), intent(inout), target :: this
    class(mlf_model_experiment), intent(in), target :: experiment
    real(c_double), intent(in) :: X(:)
    real(c_double), intent(out) :: Y(:), Cstr(:)
    integer(8) :: iMax
    integer :: nCstr, nIn
    iMax = HUGE(iMax) ! Stop when finished
    Cstr = 0
    CALL this%params%getNParameters(nCstr, nIn)
    info = this%params%set(X, Cstr(1:nCstr))
    If(info /= 0) Then
      Cstr(nCstr+1:) = HUGE(1d0)
      RETURN
    Endif
    info = this%model%reinit()
    If(info < 0) RETURN
    info = this%model%setupModel(this%params, experiment)
    If(info < 0) RETURN
    info = this%model%step(NITER = iMax)
    If(info < 0) RETURN
    info = this%model%getResults(this%results, Cstr(nCstr+1:))
    If(info < 0) RETURN
    info = this%results%vectResults(Y)
  End Function mlf_local_runExp
End Module mlf_supervised_model