!==========================================================================================!
!==========================================================================================!
!     Module phenology_startup.                                                            !
!
!     This module contains
!------------------------------------------------------------------------------------------!
module phenology_startup

   !=======================================================================================!
   !=======================================================================================!

   contains

   !=======================================================================================!
   !=======================================================================================!
   subroutine phenology_init

      use phenology_coms, only : iphen_scheme  ! ! intent(in)
      use ed_misc_coms  , only : runtype       ! ! intent(in)

      implicit none
      !----- Local parameters. ------------------------------------------------------------!
      logical,parameter :: bypass=.true.

      !----- Initialize the Botta et al. scheme. ------------------------------------------!
      select case (iphen_scheme)
      case (1)

         !---------------------------------------------------------------------------------!
         !     Initialize from satellite.  This subroutine gives ALL SITES the             !
         ! phenological parameters prescribed in the input file.                           !
         !---------------------------------------------------------------------------------!

         call read_prescribed_phenology

      case default

         !---------------------------------------------------------------------------------!
         !    Initialize thermal sums here only if no thermal sums information is avail-   !
         ! able from the restart file, or if this is a run with bare ground initial-       !
         ! ization.                                                                        !
         !---------------------------------------------------------------------------------!
         if (runtype /= 'HISTORY') then
            write (unit=*,fmt='(a)') ' - Reading thermal sums.'
            call read_thermal_sums
         end if
      end select

      return
   end subroutine phenology_init
   !=======================================================================================!
   !=======================================================================================!

   !=======================================================================================!
   !=======================================================================================!
   !    This subroutine initialises the thermal sums.  Two properties must be set at the   !
   ! beginning of the simulation:                                                          !
   !  + Chill days  (chd): number of days with average temperatures below 278.15 K.        !
   !  + Degree days (dgd): sum of daily average temperatures above 278.15 K.               !
   !---------------------------------------------------------------------------------------!
   subroutine read_thermal_sums
      use ed_max_dims   , only : str_len          ! ! intent(in)
      use ed_state_vars , only : edtype           & ! structure
                               , polygontype      & ! structure
                               , sitetype         & ! structure
                               , edgrid_g         ! ! structure
      use grid_coms     , only : ngrids           ! ! intent(in)
      use ed_misc_coms  , only : iyeara           & ! intent(in)
                               , imontha          & ! intent(in)
                               , idatea           & ! intent(in)
                               , itimea           & ! intent(in)
                               , thsums_database  & ! intent(in)
                               , max_thsums_dist  ! ! intent(in)
      implicit none
      !----- Local variables. -------------------------------------------------------------!
      type(edtype)                            , pointer     :: cgrid
      type(polygontype)                       , pointer     :: cpoly
      type(sitetype)                          , pointer     :: csite
      character(len=str_len)                                :: fyearname
      character(len=str_len)                                :: favgname
      integer                                               :: npoints
      integer                                               :: ierr
      integer                                               :: i
      integer                                               :: j
      integer                                               :: itype
      integer                                               :: igr
      integer                                               :: ipy
      integer                                               :: isi
      logical                                               :: yearthere
      logical                                               :: avgthere
      logical                                               :: iisclose
      real                  , dimension(12)                 :: ndmon
      real                  , dimension(2,12)               :: var_out
      real                  , dimension(2,12)               :: var_current_year
      real                  , dimension(2,12)               :: var_past_year
      real                  , dimension(:)    , allocatable :: flat
      real                  , dimension(:)    , allocatable :: flon
      real                  , dimension(:)    , allocatable :: fdist
      real                  , dimension(:,:,:), allocatable :: varc
      real                  , dimension(:,:,:), allocatable :: varp
      real                                                  :: tlat
      real                                                  :: tlon
      real                                                  :: partial_month_fraction
      !----- External functions. ----------------------------------------------------------!
      logical                                 , external    :: isleap
      real                                    , external    :: dist_gc
      !----- Local constants. -------------------------------------------------------------!
      character(len=3)      , dimension(2)    , parameter   :: ftype=(/'chd','dgd'/)
      !------------------------------------------------------------------------------------!

      !------------------------------------------------------------------------------------!
      !    Initialise the number of days for each month.                                   !
      !           JAN  FEB  MAR  APR  MAY  JUN  JUL  AUG  SEP  OCT  NOV  DEC               !
      !------------------------------------------------------------------------------------!
      ndmon = (/  31., 28., 31., 30., 31., 30., 31., 31., 30., 31., 30., 31. /)
      !----- Change number of days in February in case it is a leap year. -----------------!
      if (isleap(iyeara)) ndmon(2) = 29.
      !------------------------------------------------------------------------------------!

      !------------------------------------------------------------------------------------!
      !      How far are we into the current month?  Use this to weight the current and    !
      ! past year data for this month.                                                     !
      !------------------------------------------------------------------------------------!
      partial_month_fraction = (real(idatea-1) + real(itimea) * 0.01 / 24.0)               &
                             / ndmon(imontha)
      !------------------------------------------------------------------------------------!

      !------------------------------------------------------------------------------------!
      !     The two types are chilling days (chd) and degree days (dgd).                   !
      !------------------------------------------------------------------------------------!
      typeloop: do itype = 1, 2

         !----- First we try to use a file corresponding to the current year. -------------!
         write(fyearname,'(5a,i4.4,a)') trim(thsums_database),ftype(itype),'/temp.'        &
                                       ,ftype(itype),'.y',iyeara, '.dat'
         inquire (file=trim(fyearname),exist=yearthere)
         !---------------------------------------------------------------------------------!

         !----- If not, look for the average data. ----------------------------------------!
         write(favgname,'(2a)') trim(thsums_database)//ftype(itype)                        &
                               ,'/temp.'//ftype(itype)//'.avg.dat'
         inquire(file=trim(favgname),exist=avgthere)
         !---------------------------------------------------------------------------------!

         !---------------------------------------------------------------------------------!
         !     If a thermal sums file for the previous year is available, we use it to     !
         ! initialise the thermal sums.  The average files will be used only when the year !
         ! file is unavailable.  In case none of them exists, we stop the simulation.      !
         !---------------------------------------------------------------------------------!
         if (yearthere) then
            open(unit=12,file=trim(fyearname),form='formatted',status='old',action='read')
         elseif (avgthere) then
            open(unit=12,file=trim(favgname) ,form='formatted',status='old',action='read')
         else
            write (unit=*,fmt='(a)') '----------------------------------------------------'
            write (unit=*,fmt='(a)') '  Variable: '//ftype(itype)//'.'
            write (unit=*,fmt='(a)') '  Failing reading thermal sums for current year!!!'
            write (unit=*,fmt='(a)') '  You provided the following thermal sums path:'
            write (unit=*,fmt='(a)') '  THSUMS_DATABASE = '//trim(thsums_database)
            write (unit=*,fmt='(a)') '  You must provide a file with one of the following:'
            write (unit=*,fmt='(a)') '  1. This year thermal sums, named:'
            write (unit=*,fmt='(a)') '    '//trim(fyearname)
            write (unit=*,fmt='(a)') '  2. Average thermal sums, named:'
            write (unit=*,fmt='(a)') '    '//trim(favgname)
            write (unit=*,fmt='(a)') '----------------------------------------------------'
            call fatal_error (' Thermal sums file ('//ftype(itype)//') not found!!!'       &
                             ,'read_thermal_sums','phenology_startup.f90')
         end if
         !---------------------------------------------------------------------------------!

         !---------------------------------------------------------------------------------!
         !    If this is the first time, count number of points.                           !
         !---------------------------------------------------------------------------------!
         if (itype == 1) then
            npoints = 0
            count_points: do
               read(unit=12,fmt=*,iostat=ierr) tlat
               if (ierr /= 0) exit count_points
               npoints = npoints + 1
            end do count_points
            rewind(12)
            !------------------------------------------------------------------------------!

            !----- Allocate arrays. -------------------------------------------------------!
            allocate(flat(npoints))
            allocate(flon(npoints))
            allocate(fdist(npoints))
            allocate(varc(2,npoints,12))
            allocate(varp(2,npoints,12))
            varc(:,:,:) = 0.0
            varp(:,:,:) = 0.0
            !------------------------------------------------------------------------------!

         end if
         !---------------------------------------------------------------------------------!

         !----- Now we read in the file. --------------------------------------------------!
         do i=1,npoints
            read (unit=12,fmt=*) flat(i),flon(i),(varc(itype,i,j),j=1,12)
         end do
         close (unit=12,status='keep')
         !---------------------------------------------------------------------------------!

         !----- First we try to use a file corresponding to the previous year. ------------!
         write(fyearname,'(5a,i4.4,a)') trim(thsums_database),ftype(itype),'/temp.'        &
                                       ,ftype(itype),'.y',iyeara-1, '.dat'
         inquire (file=trim(fyearname),exist=yearthere)
         !---------------------------------------------------------------------------------!

         !----- If not, look for the average data. ----------------------------------------!
         write(favgname,'(2a)') trim(thsums_database)//ftype(itype)                        &
                               ,'/temp.'//ftype(itype)//'.avg.dat'
         inquire(file=trim(favgname),exist=avgthere)
         !---------------------------------------------------------------------------------!

         !---------------------------------------------------------------------------------!
         !     If a thermal sums file for the previous year is available, we use it to     !
         ! initialise the thermal sums.  The average files will be used only when the year !
         ! file is unavailable.  In case none of them exists, we stop the simulation.      !
         !---------------------------------------------------------------------------------!
         if (yearthere) then
            open(unit=12,file=trim(fyearname),form='formatted',status='old',action='read')
         elseif (avgthere) then
            open(unit=12,file=trim(favgname),form='formatted',status='old',action='read')
         else
            write (unit=*,fmt='(a)') '----------------------------------------------------'
            write (unit=*,fmt='(a)') '  Variable: '//ftype(itype)//'.'
            write (unit=*,fmt='(a)') '  Failing reading thermal sums for previous year!!!'
            write (unit=*,fmt='(a)') '  You provided the following thermal sums path:'
            write (unit=*,fmt='(a)') '  THSUMS_DATABASE = '//trim(thsums_database)
            write (unit=*,fmt='(a)') '  You must provide a file with one of the following:'
            write (unit=*,fmt='(a)') '  1. This year thermal sums, named:'
            write (unit=*,fmt='(a)') '    '//trim(fyearname)
            write (unit=*,fmt='(a)') '  2. Average thermal sums, named:'
            write (unit=*,fmt='(a)') '    '//trim(favgname)
            write (unit=*,fmt='(a)') '----------------------------------------------------'
            call fatal_error (' Thermal sums file ('//ftype(itype)//') not found!!!'       &
                             ,'read_thermal_sums','phenology_startup.f90')
         end if

         !----- Read file. ----------------------------------------------------------------!
         do i = 1, npoints
            read(unit=12,fmt=*)tlat,tlon,(varp(itype,i,j),j=1,12)
         end do
         close(unit=12,status='keep')
         !---------------------------------------------------------------------------------!

      end do typeloop
      !------------------------------------------------------------------------------------!

      !------------------------------------------------------------------------------------!
      !     Big loop over all grids.                                                       !
      !------------------------------------------------------------------------------------!
      do igr=1,ngrids
         cgrid => edgrid_g(igr)

         do ipy=1,cgrid%npolygons
            cpoly => cgrid%polygon(ipy)

            do i=1,npoints
               fdist(i) = dist_gc(cgrid%lon(ipy),flon(i),cgrid%lat(ipy),flat(i))
            end do

            !----- "i" becomes the closest grid point. ------------------------------------!
            i = minloc(fdist,dim=1)

            do isi = 1,cpoly%nsites
               csite => cpoly%site(isi)

               !----- Find the right index. -----------------------------------------------!
               iisclose     = fdist(i) < max_thsums_dist
               var_out(:,:) = 0.0

               !----- Fill this site's info. ----------------------------------------------!
               if (iisclose) then
                  do itype = 1,2
                     var_current_year(itype,1:12) = varc(itype,i,1:12)
                     var_past_year(itype,1:12)    = varp(itype,i,1:12)

                     !----- Fill contribution from current month. -------------------------!
                     var_out(itype,imontha) = partial_month_fraction                       &
                                            * var_current_year(itype,imontha)

                     !----- Fill contribution from previous months in this year. ----------!
                     var_out(itype,1:(imontha-1)) = var_current_year(itype,1:(imontha-1))

                     !----- Fill contribution from previous year. -------------------------!
                     var_out(itype,imontha) = (1.0 - partial_month_fraction)               &
                                            * var_past_year(itype,imontha)

                     !----- Fill remaining info from past year. ---------------------------!
                     var_out(itype,(imontha+1):12) = var_past_year(itype,(imontha+1):12)
                  end do
               end if

               !----- Fill the patch-level degree and chill days. -------------------------!
               call fill_thermal_sums(csite, cgrid%lat(ipy), imontha, var_out)
            end do
         end do
      end do

      deallocate(flat )
      deallocate(flon )
      deallocate(fdist)
      deallocate(varc )
      deallocate(varp )

      return
   end subroutine read_thermal_sums
   !=======================================================================================!
   !=======================================================================================!

   !=======================================================================================!
   !=======================================================================================!
   subroutine fill_thermal_sums(csite,lat,imontha,therm_sums)
      use ed_state_vars, only : sitetype
      implicit none
      !----- Arguments. -------------------------------------------------------------------!
      type(sitetype)       , target     :: csite
      real                 , intent(in) :: lat
      integer              , intent(in) :: imontha
      real, dimension(2,12), intent(in) :: therm_sums
      !----- Local variables. -------------------------------------------------------------!
      real                              :: dgd
      real                              :: chd
      integer                           :: ipa
      !------------------------------------------------------------------------------------!

      !------------------------------------------------------------------------------------!
      !     Decide how to find the thermal sums depending on the hemisphere.               !
      !------------------------------------------------------------------------------------!
      if (lat >= 0.0) then
         !----- Northern Hemisphere. ------------------------------------------------------!
         if (imontha <= 8) then
            dgd = sum(therm_sums(2,1:imontha))
         else
            dgd = 0.0
         end if

         if (imontha >= 11) then
            chd = sum(therm_sums(1,imontha:12))
         elseif (imontha <= 6) then
            chd = sum(therm_sums(1,11:12)) + sum(therm_sums(1,1:imontha))
         else
            chd = 0.0
         end if

      else

         !----- Southern Hemisphere. ------------------------------------------------------!

         if (imontha <= 2) then
            dgd = sum(therm_sums(2,7:12)) + sum(therm_sums(2,1:imontha))
         elseif (imontha >= 7) then
            dgd = sum(therm_sums(2,7:imontha))
         else
            dgd = 0.0
         end if

         if (imontha >= 5) then
            chd = sum(therm_sums(1,5:imontha))
         else
            chd = 0.0
         end if
      end if

      !----- Loop over patches. -----------------------------------------------------------!
      do ipa = 1,csite%npatches
         csite%sum_chd(ipa) = chd
         csite%sum_dgd(ipa) = dgd
      end do

      return
   end subroutine fill_thermal_sums
   !=======================================================================================!
   !=======================================================================================!

   !=======================================================================================!
   !=======================================================================================!
   !     This subroutine reads the prescribed phenology for all polygons.                  !
   !---------------------------------------------------------------------------------------!
   subroutine read_prescribed_phenology

      use ed_state_vars , only : edgrid_g              & ! structure
                               , edtype                & ! structure
                               , polygontype           & ! structure
                               , sitetype              ! ! structure
      use ed_misc_coms  , only : imontha               & ! intent(in)
                               , idatea                & ! intent(in)
                               , iyeara                ! ! intent(in)
      use grid_coms     , only : ngrids                ! ! intent(in)
      use ed_misc_coms  , only : runtype               ! ! intent(in)
      use phenology_coms, only : prescribed_phen       & ! structure
                               , phenpath              & ! intent(in)
                               , max_phenology_dist    ! ! intent(in)
      use ed_max_dims   , only : str_len               & ! intent(in)
                               , maxfiles              & ! intent(in)
                               , maxlist               ! ! intent(in)
      use phenology_aux , only : prescribed_leaf_state ! ! subroutine
      implicit none
      !----- Local variables. -------------------------------------------------------------!
      type(edtype)                              , pointer   :: cgrid
      type(polygontype)                         , pointer   :: cpoly
      type(prescribed_phen)                                 :: phen_temp
      character(len=str_len), dimension(maxlist)            :: full_list
      character(len=str_len), dimension(maxlist)            :: phen_list
      real                  , dimension(maxlist)            :: phen_lon
      real                  , dimension(maxlist)            :: phen_lat
      real                  , dimension(maxlist)            :: phen_dist
      character(len=str_len)                                :: phen_file
      integer                                               :: igr
      integer                                               :: isi
      integer                                               :: ipy
      integer                                               :: iyr
      integer                                               :: doy
      integer                                               :: ncl
      integer                                               :: nf
      integer                                               :: nflist
      integer                                               :: nfphen
      integer                                               :: yearsa
      integer                                               :: yearsz
      !----- Local constants. ----------------------------------------------------------------!
      character(len=12)                         , parameter :: fffmt='(a,1x,f12.5)'
      character(len=13)                         , parameter :: esfmt='(a,1x,es12.5)'
      !----- External functions. ----------------------------------------------------------!
      integer                                   , external  :: julday
      real                                      , external  :: dist_gc
      !------------------------------------------------------------------------------------!

      !------ List all files that has the phenology prefix. -------------------------------!

      call ed_filelist(full_list,phenpath,nflist)
      call ed1_fileinfo('.txt',nflist,full_list,nfphen,phen_list,phen_lon,phen_lat)
      !------------------------------------------------------------------------------------!

      gridloop: do igr = 1,ngrids
         cgrid => edgrid_g(igr)

         polyloop: do ipy = 1,cgrid%npolygons
            cpoly => cgrid%polygon(ipy)

            !------------------------------------------------------------------------------!
            !     Compute the distance between the current polygon and the phenology       !
            ! files.  Pick up the closest file.                                            !
            !------------------------------------------------------------------------------!
            do nf = 1, nfphen
               phen_dist(nf) = dist_gc(cgrid%lon(ipy),phen_lon(nf)                         &
                                      ,cgrid%lat(ipy),phen_lat(nf))
            end do
            ncl = minloc(phen_dist(1:nfphen),dim=1)
            phen_file=phen_list(ncl)

            !----- Check whether the closest phenology file is enough close... ------------!
            if (phen_dist(ncl) > max_phenology_dist) then
               write (unit=*,fmt='(a)') '-------------------------------------------------'
               write (unit=*,fmt='(a)') ' The closest phenology point is too far away...'
               write (unit=*,fmt=*)     ' '
               write (unit=*,fmt=fffmt) ' Polygon longitude:          ',cgrid%lon(ipy)
               write (unit=*,fmt=fffmt) ' Polygon latitude:           ',cgrid%lat(ipy)
               write (unit=*,fmt=fffmt) ' Closest phenology longitude:',phen_lon(ncl)
               write (unit=*,fmt=fffmt) ' Closest phenology latitude: ',phen_lat(ncl)
               write (unit=*,fmt=esfmt) ' Distance:                   ',phen_dist(ncl)
               write (unit=*,fmt=esfmt) ' Maximum accepted distance:  ',max_phenology_dist
               write (unit=*,fmt='(a)') '-------------------------------------------------'
               write (unit=*,fmt=*)     ' '
               call fatal_error('No valid phenology file was found!!!'                     &
                               ,'read_prescribed_phenology','phenology_init.f90')
            end if

            !----- Open phenology file. ---------------------------------------------------!
            open(unit=12,file=trim(phen_file),form='formatted',status='old',action='read')

            !----- Read the number of years, and allocate the temporary array. ------------!
            read(unit=12,fmt=*) phen_temp%nyears
            allocate(phen_temp%years  (phen_temp%nyears))
            allocate(phen_temp%flush_a(phen_temp%nyears))
            allocate(phen_temp%flush_b(phen_temp%nyears))
            allocate(phen_temp%color_a(phen_temp%nyears))
            allocate(phen_temp%color_b(phen_temp%nyears))

            !----- Read the remaining lines. ----------------------------------------------!
            do iyr = 1,phen_temp%nyears
               read(unit=12,fmt=*)  phen_temp%years(iyr)  , phen_temp%flush_a(iyr)         &
                                  , phen_temp%flush_b(iyr), phen_temp%color_a(iyr)         &
                                  , phen_temp%color_b(iyr)
            end do
            close (unit=12,status='keep')

            !----- Write phenology to each site. ------------------------------------------!
            siteloop: do isi = 1,cpoly%nsites

               !----- Allocate memory for all years having data. --------------------------!
               cpoly%phen_pars(isi)%nyears = phen_temp%nyears
               allocate(cpoly%phen_pars(isi)%years(cpoly%phen_pars(isi)%nyears))
               allocate(cpoly%phen_pars(isi)%flush_a(cpoly%phen_pars(isi)%nyears))
               allocate(cpoly%phen_pars(isi)%flush_b(cpoly%phen_pars(isi)%nyears))
               allocate(cpoly%phen_pars(isi)%color_a(cpoly%phen_pars(isi)%nyears))
               allocate(cpoly%phen_pars(isi)%color_b(cpoly%phen_pars(isi)%nyears))

               do iyr = 1,phen_temp%nyears
                  cpoly%phen_pars(isi)%years(iyr)   = phen_temp%years(iyr)
                  cpoly%phen_pars(isi)%flush_a(iyr) = phen_temp%flush_a(iyr)
                  cpoly%phen_pars(isi)%flush_b(iyr) = phen_temp%flush_b(iyr)
                  cpoly%phen_pars(isi)%color_a(iyr) = phen_temp%color_a(iyr)
                  cpoly%phen_pars(isi)%color_b(iyr) = phen_temp%color_b(iyr)
               enddo

               !----- Initialize green_leaf_factor and leaf_aging_factor. -----------------!
               doy = julday(imontha,idatea,iyeara)

               if(runtype /= 'HISTORY') then

                  print *, cpoly%a_par(isi)
                  print *,
                  print *,
                  print *,
                  print *,
                  print *,
                  print *,
                  print *,
                  print *,

                  yearsa = phen_temp%years(1)
                  yearsz = phen_temp%years(phen_temp%nyears)

                  if(iyeara > yearsz) then
                     if(doy .lt. 212) then
                        cpoly%a_par(isi) = phen_temp%flush_a(mod(iyeara-phen_temp%years(1),phen_temp%nyears)+1)
                        cpoly%b_par(isi) = phen_temp%flush_b(mod(iyeara-phen_temp%years(1),phen_temp%nyears)+1)
                     else
                        cpoly%a_par(isi) = phen_temp%color_a(mod(iyeara-phen_temp%years(1),phen_temp%nyears)+1)
                        cpoly%b_par(isi) = phen_temp%color_b(mod(iyeara-phen_temp%years(1),phen_temp%nyears)+1)
                     end if

                     cpoly%a_fall(isi) = phen_temp%color_a(mod(iyeara-phen_temp%years(1),phen_temp%nyears)+1)
                  elseif(iyeara < yearsa) then
                     if(doy .lt. 212) then
                        cpoly%a_par(isi) = phen_temp%flush_a(phen_temp%nyears - &
                             mod(phen_temp%years(phen_temp%nyears)-iyeara,phen_temp%nyears))
                        cpoly%b_par(isi) = phen_temp%flush_b(phen_temp%nyears - &
                             mod(phen_temp%years(phen_temp%nyears)-iyeara,phen_temp%nyears))
                     else
                        cpoly%a_par(isi) = phen_temp%color_a(phen_temp%nyears - &
                             mod(phen_temp%years(phen_temp%nyears)-iyeara,phen_temp%nyears))
                        cpoly%b_par(isi) = phen_temp%color_b(phen_temp%nyears - &
                             mod(phen_temp%years(phen_temp%nyears)-iyeara,phen_temp%nyears))
                     end if

                     cpoly%a_fall(isi) = phen_temp%color_a(phen_temp%nyears - &
                             mod(phen_temp%years(phen_temp%nyears)-iyeara,phen_temp%nyears))
                  else
                     if(doy .lt. 212) then
                        cpoly%a_par(isi) = phen_temp%flush_a(iyeara - phen_temp%years(1) + 1)
                        cpoly%b_par(isi) = phen_temp%flush_b(iyeara - phen_temp%years(1) + 1)
                     else
                        cpoly%a_par(isi) = phen_temp%color_a(iyeara - phen_temp%years(1) + 1)
                        cpoly%b_par(isi) = phen_temp%color_b(iyeara - phen_temp%years(1) + 1)
                     end if

                     cpoly%a_fall(isi) = phen_temp%color_a(iyeara - phen_temp%years(1) + 1)
                  end if

                  call prescribed_leaf_state(cgrid%lat(ipy), imontha, iyeara, doy                &
                                      ,cpoly%green_leaf_factor(:,isi)                      &
                                      ,cpoly%leaf_aging_factor(:,isi),cpoly%phen_pars(isi) &
                                      ,cpoly%a_par(isi),cpoly%b_par(isi),cpoly%a_fall(isi))
               end if
            end do siteloop

            deallocate(phen_temp%years)
            deallocate(phen_temp%flush_a)
            deallocate(phen_temp%flush_b)
            deallocate(phen_temp%color_a)
            deallocate(phen_temp%color_b)

         end do polyloop
      end do gridloop

      return
   end subroutine read_prescribed_phenology
   !=======================================================================================!
   !=======================================================================================!

end module phenology_startup
!==========================================================================================!
!==========================================================================================!


      module comfi
!    comfi
!***********************************************************************
!  Copyright, 1993, 2004,  The  Regents of the University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
!**********************************************************************
!D1
!D1 PURPOSE
!D1
!D1 Include file containing passed parameters and pointers related to
!D1 memory management.
!D1
!**********************************************************************
!D2
!D2 REVISION HISTORY
!D2
!D2 Revision                    ECD
!D2 Date         Programmer     Number  Comments
!D2
!D2 09-13-93     B. Robinson    00022   Initial Implementation
!D2
!D2 $Log:   /pvcs.config/fehm90/src/comfi.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:42:30   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 08:56:46   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:05:34   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:22:30   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 11:56:52   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:39:40 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
!D2
!D2    Rev 1.2   01/28/95 14:07:10   llt
!D2 water balance equation was modified
!D2
!D2    Rev 1.1   03/18/94 16:23:08   gaz
!D2 Added solve_new and cleaned up memory management.
!D2
!D2    Rev 1.0   01/20/94 10:22:06   pvcs
!D2 original version in process of being certified
!D2 10/28/94 GAZ  added dqpc , the derivative of total source wrt air pressure
!D2
!**********************************************************************
!D3
!D3 INTERFACES
!D3
!D3 None
!D3
!**********************************************************************
!D4
!D4 GLOBAL OBJECTS
!D4
!D4 Global Constants
!D4
!D4   None
!D4
!D4 Global Types
!D4
!D4   None
!D4
!D4 Global Variables
!D4
!D4                            COMMON
!D4   Identifier      Type     Block  Description
!D4
!D4   ***** COMMON Block co2 pointers and associated variables *****
!D4   ipcnlf          POINTER  co2    Pointer for variable cnlf
!D4   ipcnvf          POINTER  co2    Pointer for variable cnvf
!D4   ipdcc           POINTER  co2    Pointer for variable dcc
!D4   ipdce           POINTER  co2    Pointer for variable dce
!D4   ipdclcf         POINTER  co2    Pointer for variable dclcf
!D4   ipdclef         POINTER  co2    Pointer for variable dclef
!D4   ipdclf          POINTER  co2    Pointer for variable dclf
!D4   ipdcp           POINTER  co2    Pointer for variable dcp
!D4   ipdcqc          POINTER  co2    Pointer for variable dcqc
!D4   ipdcqh          POINTER  co2    Pointer for variable dcqh
!D4   ipdcvcf         POINTER  co2    Pointer for variable dcvcf
!D4   ipdcvef         POINTER  co2    Pointer for variable dcvef
!D4   ipdcvf          POINTER  co2    Pointer for variable dcvf
!D4   ipdec           POINTER  co2    Pointer for variable dec
!D4   ipdelcf         POINTER  co2    Pointer for variable delcf
!D4   ipdenpch        POINTER  co2    Pointer for variable denpch
!D4   ipdenpci        POINTER  co2    Pointer for variable denpci
!D4   ipdenpcj        POINTER  co2    Pointer for variable denpcj
!D4   ipdeqc          POINTER  co2    Pointer for variable deqc
!D4   ipdevcf         POINTER  co2    Pointer for variable devcf
!D4   ipdglc          POINTER  co2    Pointer for variable dglc
!D4   ipdgvc          POINTER  co2    Pointer for variable dgvc
!D4   ipdilc          POINTER  co2    Pointer for variable dilc
!D4   ipdivc          POINTER  co2    Pointer for variable divc
!D4   ipdmc           POINTER  co2    Pointer for variable dmc
!D4   ipdqc           POINTER  co2    Pointer for variable dqc
!D4   ipdtpac         POINTER  co2    Pointer for variable dtpac
!D4   ipeskc          POINTER  co2    Pointer for variable eskc
!D4   ippci           POINTER  co2    Pointer for variable pci
!D4   ippcio          POINTER  co2    Pointer for variable pcio
!D4   ipqc            POINTER  co2    Pointer for variable qc
!D4   ipdqpc          POINTER  co2    Pointer for variable dqpc
!D4   ipsici          POINTER  co2    Pointer for variable sici
!D4
!D4   cnlf            REAL*8   co2    Gas concentration in the liquid phase
!D4   cnvf            REAL*8   co2    !oncentration of gas in the vapor phase
!D4   dcc             REAL*8   co2    Derivative of gas accumulation term with
!D4                                     respect to gas
!D4   dce             REAL*8   co2    Derivative of gas accumulation term with
!D4                                     respect to energy at each node
!D4   dclcf           REAL*8   co2    Derivative of liquid concentration with
!D4                                     respect to gas
!D4   dclef           REAL*8   co2    Derivative of liquid concentration with
!D4                                     respect to energy
!D4   dclf            REAL*8   co2    Derivative of liquid concentration with
!D4                                     respect to pressure
!D4   dcp             REAL*8   co2    Derivative of gas accumulation term with
!D4                                     respect to pressure at each node
!D4   dcqc            REAL*8   co2    Derivative of gas source term with
!D4                                     respect to gas
!D4   dcqh            REAL*8   co2    Derivative of gas source term with
!D4                                     respect to energy
!D4   dcvcf           REAL*8   co2    Derivative of gas concentration with
!D4                                     respect to gas
!D4   dcvef           REAL*8   co2    Derivative of gas concentration with
!D4                                     respect to energy
!D4   dcvf            REAL*8   co2    Derivative of gas concentration with
!D4                                     respect to pressure
!D4   dec             REAL*8   co2    Derivative of energy accumulation term
!D4                                     with respect to gas at each node
!D4   delcf           REAL*8   co2    Derivative of liquid energy with respect
!D4                                     to gas
!D4   denpch          REAL*8   co2    Last time step value of the mass
!D4                                     accumulation term at each node
!D4   denpci          REAL*8   co2    Gas accumulation term at each node
!D4   denpcj          REAL*8   co2    Last time step accumulation term of gas
!D4                                     equation
!D4   deqc            REAL*8   co2    Derivative of energy source term with
!D4                                     respect to gas
!D4   devcf           REAL*8   co2    Derivative of energy with respect to gas
!D4   dglc            REAL*8   co2    Derivative of liquid gravity term with
!D4                                     respect to gas
!D4   dgvc            REAL*8   co2    Derivative of vapor gravity term with
!D4                                     respect to gas
!D4   dilc            REAL*8   co2    Derivative of liquid transmissibility
!D4                                     with respect to gas
!D4   divc            REAL*8   co2    Derivative of vapor transmissibility
!D4                                     with respect to gas
!D4   dmc             REAL*8   co2    Derivative of mass accumulation term
!D4                                     with respect to gas at each node
!D4   dqc             REAL*8   co2    Derivative of mass source term with
!D4                                     respect to gas
!D4   dtpac           REAL*8   co2    Derivative of temperature with respect
!D4                                     to gas
!D4   eskc            REAL*8   co2    Source term for gas equation
!D4   pci             REAL*8   co2    Gas pressure
!D4   pcio            REAL*8   co2    Last time step gas pressure
!D4   qc              REAL*8   co2    Source term for the gas equation
!D4   dqpc            REAL*8   co2    derivative of total source wrt air pressure
!D4   sici            REAL*8   co2    Array in ice solution
!D4
!D4   ***** COMMON Block co2r variables *****
!D4   acner           REAL*8   co2r   Total mass accumulation at a time step
!D4   amc             REAL*8   co2r   Total mass accumulation at a time step
!D4   difc            REAL*8   co2r   Noncondensible gas mass balance error
!D4   qtc             REAL*8   co2r   Total mass injected in source term
!D4   qtotc           REAL*8   co2r   Total mass injected in source term
!D4
!**********************************************************************
!D5
!D5 LOCAL IDENTIFIERS
!D5
!D5 None
!D5
!**********************************************************************
!D6
!D6 FUNCTIONAL DESCRIPTION
!D6
!D6 None
!D6
!**********************************************************************
!D7
!D7 ASSUMPTIONS AND LIMITATIONS
!D7
!D7 None
!D7
!**********************************************************************
!D8
!D8 SPECIAL COMMENTS
!D8
!D8 None
!D8
!**********************************************************************
!D9
!D9 REQUIREMENTS TRACEABILITY
!D9
!D9 None
!D9
!**********************************************************************
!DA
!DA REFERENCES
!DA
!DA None
!DA
!**********************************************************************
!PS
!PS PSEUDOCODE
!PS
!PS None
!PS
!**********************************************************************

      real*8, allocatable ::  cnlf(:)
      real*8, allocatable ::  cnvf(:)
      real*8, allocatable ::  dcc(:)
      real*8, allocatable ::  dce(:)
      real*8, allocatable ::  dclcf(:)
      real*8, allocatable ::  dclef(:)
      real*8, allocatable ::  dclf(:)
      real*8, allocatable ::  dcp(:)
      real*8, allocatable ::  dcqc(:)
      real*8, allocatable ::  dcqh(:)
      real*8, allocatable ::  dcvcf(:)
      real*8, allocatable ::  dcvef(:)
      real*8, allocatable ::  dcvf(:)
      real*8, allocatable ::  dec(:)
      real*8, allocatable ::  delcf(:)
      real*8, allocatable ::  denpch(:)
      real*8, allocatable ::  denpci(:)
      real*8, allocatable ::  denpcj(:)
      real*8, allocatable ::  deqc(:)
      real*8, allocatable ::  devcf(:)
      real*8, allocatable ::  dglc(:)
      real*8, allocatable ::  dgvc(:)
      real*8, allocatable ::  dilc(:)
      real*8, allocatable ::  divc(:)
      real*8, allocatable ::  dmc(:)
      real*8, allocatable ::  dqc(:)
      real*8, allocatable ::  dtpac(:)
      real*8, allocatable ::  eskc(:)
      real*8, allocatable ::  pci(:)
      real*8, allocatable ::  pcio(:)
      real*8, allocatable ::  qc(:)
      real*8, allocatable ::  qng(:)
      real*8, allocatable ::  dqpc(:)
      real*8, allocatable ::  sici(:)
      real*8, allocatable ::  flux_ts(:)

!     ***** Variables in COMMON Block co2r *****
      real*8 acner, amc, difc, qtc, qtotc

      end module comfi


module jcmod
!$$$   module documentation block
!                .      .    .                                       .
! module:    jcmod           contains stuff for Jc penalty
!
!   prgmmr: kleist           org: np20                date: 2005-07-01
!
! abstract:  contains routines and variables for dynamic constraint
!            term
!
! program history log:
!   2005-07-01
!   2005-09-29  kleist, expand to include variables for more terms
!   2005-11-21  kleist, remove tendency arrays
!   2006-04-06  kleist, expand and redefine Jc term for two formulations
!   2007-10-18  tremolet - added Jc DFI option
!   2012-02-08  kleist - add parameter ljc4tlevs
!   2013-05-15  todling - add knobs to control constraint on total water
!   2018-05-19  eliu - add logic (ljclimqc) for limiting negative hydrometeors
!                      as a weak constraint
!
! subroutines included:
!   sub init_jcvars          - initialize Jc related variables
!
! Variable Definitions:
!   def ljcdfi               - if true, use digital filter Jc
!   def alphajc              - multiplying factor for Jc DFI
!   def ljc4tlevs            - if true, apply jc (limq, pdry) over all time levels if in 4D mode
!
!   The z_* arrays are used to accumulate information from previous outer loops regarding
!      congributions to the Jc term
!      Their definitions depend on formulation:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

  use kinds, only: r_kind
  implicit none

! set default to private
  private
! set subroutines to public
  public :: init_jcvars
! set passed variables to public
  public :: ljcdfi,alphajc,wgtdfi,bamp_jcpdry,ljcpdry,eps_eer
  public :: ljc4tlevs
  public :: ljclimqc

  logical ljcdfi,ljcpdry,ljc4tlevs,ljclimqc
  real(r_kind) alphajc,bamp_jcpdry,eps_eer
  real(r_kind),allocatable :: wgtdfi(:)

contains

  subroutine init_jcvars
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    init_jcvars     initial Jc related variables
!   prgmmr: kleist          org: np20                date: 2005-07-01
!
! abstract: initialize dynamic constraint term variables
!
! program history log:
!   2005-07-01  kleist
!   2005-09-29  kleist, expanded for new terms
!   2006-04-06  kleist, include both formulations
!   2010-09-06  todling, add Errico-Ehrendorfer parameter for E-norm
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block
    use constants, only: zero,one
    implicit none

! load defaults for non-allocatable arrays
    ljclimqc=.false.
    ljcdfi=.false.
    ljcpdry=.false.
    ljc4tlevs=.false.
    alphajc=10.0_r_kind
    bamp_jcpdry=zero
    eps_eer=-one  ! default: don't use q-term in norm

    return
  end subroutine init_jcvars

end module jcmod


        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:59:45 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE UPDATE_DISPLACEMENT_PRECONDITION_NEWMARK_ACOUSTIC__genmod
          INTERFACE
            SUBROUTINE UPDATE_DISPLACEMENT_PRECONDITION_NEWMARK_ACOUSTIC&
     &(DELTAT,DELTATOVER2,DELTATSQUAREOVER2,POTENTIAL_DOT_DOT_ACOUSTIC, &
     &POTENTIAL_DOT_ACOUSTIC,POTENTIAL_ACOUSTIC,POTENTIAL_ACOUSTIC_OLD, &
     &PML_BOUNDARY_CONDITIONS)
              USE SPECFEM_PAR, ONLY :                                   &
     &          NGLOB_ACOUSTIC
              REAL(KIND=8) :: DELTAT
              REAL(KIND=8) :: DELTATOVER2
              REAL(KIND=8) :: DELTATSQUAREOVER2
              REAL(KIND=4) :: POTENTIAL_DOT_DOT_ACOUSTIC(NGLOB_ACOUSTIC)
              REAL(KIND=4) :: POTENTIAL_DOT_ACOUSTIC(NGLOB_ACOUSTIC)
              REAL(KIND=4) :: POTENTIAL_ACOUSTIC(NGLOB_ACOUSTIC)
              REAL(KIND=4) :: POTENTIAL_ACOUSTIC_OLD(NGLOB_ACOUSTIC)
              LOGICAL(KIND=4) :: PML_BOUNDARY_CONDITIONS
            END SUBROUTINE                                              &
     &UPDATE_DISPLACEMENT_PRECONDITION_NEWMARK_ACOUSTIC
          END INTERFACE
        END MODULE                                                      &
     &UPDATE_DISPLACEMENT_PRECONDITION_NEWMARK_ACOUSTIC__genmod


MODULE OMSAO_omidata_module

  USE OMSAO_precision_module
  USE OMSAO_parameters_module, ONLY: maxchlen, max_spec_pts
  USE OMSAO_indices_module,    ONLY: n_max_fitpars, max_rs_idx, max_calfit_idx, o3_t1_idx, o3_t3_idx
  IMPLICIT NONE

  ! ------------------------------------------------------------
  ! Boundary wavelengths (approximate) for UV-2 and VIS channels
  ! ------------------------------------------------------------
  REAL (KIND=r4), PARAMETER :: uv2_upper_wvl = 385.0_r4, vis_lower_wvl = 350.0_r4

  ! ---------------------------------------
  ! Minimum OMI spectral resolution (in nm)
  ! ---------------------------------------
  REAL (KIND=r8), PARAMETER :: omi_min_specres = 0.5_r8

  ! ---------------------------------
  ! Maximum OMI data/swath dimensions
  ! ---------------------------------
  INTEGER (KIND=i4), PARAMETER :: &
       nxtrack_max    =  60, nwavel_max = 1024, &
       nwavelcoef_max =   5, nlines_max =  100, &
       nUTCdim        =   6

  ! -------------------------------------------------------
  ! Maximum dimension of OMI data fields in SAO L2 products
  ! -------------------------------------------------------
  INTEGER (KIND=i4), PARAMETER :: n_field_maxdim = 3

  ! --------------------------------------------------
  ! Parameters defined by the NISE snow cover approach
  ! --------------------------------------------------
  INTEGER (KIND=i2), PARAMETER :: &
       NISE_snowfree =   0, NISE_allsnow = 100, NISE_permice = 101, NISE_drysnow = 103, &
       NISE_ocean    = 104, NISE_suspect = 125, NISE_error   = 127

  ! --------------------------------------------------------------------
  ! Values to go into the diagnostic array that shows how the AMF was
  ! computed, with values that indicate missing cloud products, glint,
  ! and geometric or no AMF
  ! --------------------------------------------------------------------
  INTEGER (KIND=i2), PARAMETER :: &
       omi_cfr_addmiss = 1000, omi_ctp_addmiss = 2000, omi_glint_add = 10000, &
       omi_oob_cfr =  210, omi_oob_ctp     =  220, omi_oob_cli = -3, &
       omi_geo_amf = -1,   omi_oobview_amf = -2, omi_wfmod_amf = -9, omi_bigsza_amf = 500

  ! -----------------------
  ! Arrays for OMI L1b data
  ! -----------------------
  INTEGER (KIND=i2)                                                    :: omi_mflg
  REAL    (KIND=r4), DIMENSION (0:nlines_max-1)                        :: omi_auraalt
  REAL    (KIND=r8), DIMENSION (0:nlines_max-1)                        :: omi_time
  INTEGER (KIND=i4), DIMENSION (0:nlines_max-1)                        :: omi_radiance_errstat
  INTEGER (KIND=i1), DIMENSION (nxtrack_max,0:nlines_max-1)            :: omi_xtrflg_l1b
  INTEGER (KIND=i2), DIMENSION (nxtrack_max,0:nlines_max-1)            :: omi_geoflg, omi_xtrflg
  INTEGER (KIND=i2), DIMENSION (nxtrack_max,0:nlines_max-1)            :: omi_height, land_water_flg
  REAL    (KIND=r4), DIMENSION (nxtrack_max,0:nlines_max-1)            :: omi_latitude, omi_longitude
  REAL    (KIND=r4), DIMENSION (nxtrack_max,0:nlines_max-1)            :: omi_szenith, omi_sazimuth
  REAL    (KIND=r4), DIMENSION (nxtrack_max,0:nlines_max-1)            :: omi_vzenith, omi_vazimuth
  REAL    (KIND=r8), DIMENSION (nwavel_max,nxtrack_max,0:nlines_max-1) :: omi_radiance_spec
  REAL    (KIND=r8), DIMENSION (nwavel_max,nxtrack_max,0:nlines_max-1) :: omi_radiance_prec
  REAL    (KIND=r8), DIMENSION (nwavel_max,nxtrack_max,0:nlines_max-1) :: omi_radiance_wavl
  INTEGER (KIND=i2), DIMENSION (nwavel_max,nxtrack_max,0:nlines_max-1) :: omi_radiance_qflg
  INTEGER (KIND=i4), DIMENSION (nwavel_max,nxtrack_max,0:nlines_max-1) :: omi_radiance_ccdpix
  INTEGER (KIND=i2), DIMENSION (nUTCdim,0:nlines_max-1)                :: omi_time_utc

  ! ---------------------------------------------------------------
  ! Snow/Ice and Glint flags are used in the AMF computation module
  ! outside the "nlines_max" loops and hence need to be defined on
  ! the maximum swath dimensions.
  ! ---------------------------------------------------------------
  INTEGER (KIND=i4), DIMENSION (nwavel_max,nxtrack_max) :: omi_irradiance_ccdpix
  INTEGER (KIND=i2), DIMENSION (nwavel_max,nxtrack_max) :: omi_irradiance_qflg, omi_radref_qflg
  REAL    (KIND=r8), DIMENSION (nwavel_max,nxtrack_max) :: &
       omi_irradiance_prec, omi_irradiance_wavl, omi_irradiance_spec, omi_irradiance_wght, &
       omi_radref_spec, omi_radref_wavl, omi_radref_wght
  REAL    (KIND=r4), DIMENSION (nxtrack_max) :: omi_radref_sza, omi_radref_vza

  ! ---------------------------------------------------------------
  ! Scene Albedo, from OMCLDO2, for Wavelength-Modified AMF lookup
  ! ---------------------------------------------------------------
  REAL (KIND=r4), DIMENSION (nxtrack_max) :: omi_scene_albedo

  INTEGER (KIND=i4), DIMENSION (nxtrack_max,4) :: omi_ccdpix_selection
  INTEGER (KIND=i4), DIMENSION (nxtrack_max,2) :: omi_ccdpix_exclusion

  ! ----------------------------------------
  ! Arrays for fitting and/or derived output
  ! ----------------------------------------
  REAL    (KIND=r8), PARAMETER                              :: d_comm_wvl = 0.01_r8
  INTEGER (KIND=i4)                                         :: n_comm_wvl
  INTEGER (KIND=i4), DIMENSION (nxtrack_max)                :: common_cnt
  REAL    (KIND=r8), DIMENSION (nxtrack_max,max_spec_pts)   :: common_spc, common_wvl
  REAL    (KIND=r8), DIMENSION (nxtrack_max,0:nlines_max-1) :: &
       omi_column_amount, omi_column_uncert, omi_fit_rms, omi_radfit_chisq
  REAL    (KIND=r8), ALLOCATABLE, DIMENSION(:,:)            :: omi_ozone_amount
  REAL    (KIND=r4), DIMENSION (nxtrack_max,0:nlines_max-1) :: omi_razimuth
  INTEGER (KIND=i2), DIMENSION (nxtrack_max,0:nlines_max-1) :: omi_fitconv_flag
  INTEGER (KIND=i2), DIMENSION (nxtrack_max,0:nlines_max-1) :: omi_itnum_flag

  ! ----------------------------------------------------------------------------
  ! Correlations with main output product. Due to a bug in the HDF-EOS5 routines
  ! (non-TLCF implementation), STRING fields cannot be written to file directly.
  ! A work-around solution is to convert the CHARACTERs to INTEGERs. Thus the
  ! need for the additional array CORRELATION_NAMES_INT.
  ! ----------------------------------------------------------------------------
  CHARACTER (LEN=maxchlen), DIMENSION (n_max_fitpars) :: correlation_names
  CHARACTER (LEN=n_max_fitpars*maxchlen)              :: correlation_names_concat

  ! --------------------------------------------------------
  ! Ozone is a special case: We can have up to 3 temperatues
  ! --------------------------------------------------------
  REAL (KIND=r8), DIMENSION (o3_t1_idx:o3_t3_idx, nxtrack_max,0:nlines_max-1) :: &
       omi_o3_amount, omi_o3_uncert

  ! ---------------------------------
  ! Dimensions for measurement swaths
  ! ---------------------------------
  !INTEGER (KIND=i4) :: ntimes, ntimessmallpixel, nxtrack, nwavel, ntimes_loop, nwavel_ccd
  INTEGER (KIND=i4) :: ntimessmallpixel, nwavel, ntimes_loop
  INTEGER (KIND=i4), DIMENSION (nxtrack_max)                  :: omi_nwav_irrad, omi_nwav_radref
  INTEGER (KIND=i4), DIMENSION (nxtrack_max,0:nlines_max-1)   :: omi_nwav_rad

  ! ---------------------------------------
  ! Swath attributes for measurement swaths
  ! ---------------------------------------
  INTEGER (KIND=i2) :: ImageBinningFactor, BinnedImageRows, StopColumn
  INTEGER (KIND=i4) :: NumTimes, NumTimesSmallPixel

  INTEGER (KIND=i4), DIMENSION (nxtrack_max)                         :: n_omi_database_wvl
  INTEGER (KIND=i2), DIMENSION (nxtrack_max)                         :: &
       omi_solcal_itnum, omi_radcal_itnum, omi_radref_itnum,            &
       omi_solcal_xflag, omi_radcal_xflag, omi_radref_xflag
  REAL    (KIND=r8), DIMENSION (max_calfit_idx, nxtrack_max)         :: &
       omi_solcal_pars,  omi_radcal_pars,  omi_radref_pars
  REAL    (KIND=r8), DIMENSION (max_rs_idx, nwavel_max, nxtrack_max) :: omi_database
  REAL    (KIND=r8), DIMENSION (            nwavel_max, nxtrack_max) :: omi_database_wvl
  REAL    (KIND=r8), DIMENSION (nxtrack_max)                         :: omi_sol_wav_avg
  REAL    (KIND=r8), DIMENSION (nxtrack_max)                         :: &
       omi_solcal_chisq, omi_radcal_chisq, omi_radref_chisq, &
       omi_radref_col,   omi_radref_dcol,  omi_radref_rms,   &
       omi_radref_xtrcol
  REAL    (KIND=r8), DIMENSION (2,nxtrack_max,0:nlines_max-1)        :: omi_wavwin_rad, omi_fitwin_rad
  REAL    (KIND=r8), DIMENSION (2,nxtrack_max)                       :: omi_wavwin_sol, omi_fitwin_sol

  ! ---------------
  ! OMI swath names
  ! ---------------
  CHARACTER (LEN=maxchlen) :: omi_radiance_swathname, omi_irradiance_swathname
  CHARACTER (LEN=maxchlen) :: l1b_radiance_esdt

  ! ------------------------------
  ! Distance between Earth and Sun
  ! ------------------------------
  REAL (KIND=r4) :: EarthSunDistance

  ! ---------------------------------------------------------
  ! OMI scan line, block line, and across-track pixel numbers
  ! ---------------------------------------------------------
  INTEGER (KIND=i4) :: omi_scanline_no, omi_blockline_no, omi_xtrackpix_no

  ! ---------------------------
  ! OMI L2 output data QA flags
  ! ----------------------------------------------------------------
  ! Per Centages of output column data that are used to classify the
  ! scientific data quality:
  !         Good data >= QA_PERCENT_PASS   : "Passed"
  !         Good data >= QA_PERCENT_SUSPECT: "Suspect"
  !         Good data <  QA_PERCENT_SUSPECT: "Failed"
  ! ----------------------------------------------------------------
  INTEGER (KIND=i4), PARAMETER :: qa_percent_passed = 75, qa_percent_suspect = 50

  ! ------------------------------------------------------
  ! Finally some variables that will be initialized in the
  ! course of the processing.
  ! ------------------------------------------------------
  INTEGER (KIND=i4) :: &
       n_omi_radwvl, n_omi_radrefwvl, n_omi_irradwvl,  &
       nwavelcoef_irrad, nwavelcoef_rad,               &
       ntimes_smapix_irrad, ntimes_smpix_rad, nclenfit

  ! --------------------------------
  ! Current cross-track pixel number
  ! --------------------------------
  INTEGER (KIND=i4) :: curr_xtrack_pixnum

  LOGICAL, DIMENSION (nxtrack_max) ::  omi_cross_track_skippix = .FALSE.

  ! ------------------------------------
  ! Number of significant digits to keep
  ! ------------------------------------
  INTEGER (KIND=i4), PARAMETER :: n_roff_dig = 5

  ! ----------------------------------------------------------
  ! Variables and parameters associated with Spatial Zoom data
  ! ----------------------------------------------------------
  CHARACTER (LEN=16), PARAMETER :: uv1_glob_swath = 'Earth UV-1 Swath'
  CHARACTER (LEN=10), PARAMETER ::    &
       uv1_zoom_swath = '(60x159x4)', &
       uv2_zoom_swath = '(60x557x4)', &
       vis_zoom_swath = '(60x751x4)'

  INTEGER (KIND=i4), PARAMETER :: gzoom_spix = 16, gzoom_epix = 45, gzoom_npix = 30
  INTEGER (KIND=i1), PARAMETER :: global_mode = 8_i1, szoom_mode = 4_i1
  INTEGER (KIND=i1)            :: truezoom, fullswath

  INTEGER (KIND=i4) :: omi_l1b_idx

  ! -----------------------------------------
  ! Index to keep track of the line we are in
  ! -----------------------------------------
  INTEGER (KIND=i4) :: omi_iline
END MODULE OMSAO_omidata_module


      SUBROUTINE INTGRT
*
*
*       N-body integrator flow control.
*       -------------------------------
*
      INCLUDE 'common6.h'
      COMMON/CLUMP/   BODYS(NCMAX,5),T0S(5),TS(5),STEPS(5),RMAXS(5),
     &                NAMES(NCMAX,5),ISYS(5)
      COMMON/CHAINC/  XC(3,NCMAX),UC(3,NCMAX),BODYC(NCMAX),ICH,
     &                LISTC(LMAX)
      COMMON/PREDICT/ TPRED(NMAX)
      INTEGER ISTAT(NMAX)
      PARAMETER (NIMAX=1024,NPMAX=16)
      REAL*8   H2I(NIMAX),XI(3,NIMAX),VI(3,NIMAX),GPUACC(3,NIMAX),
     &         GPUJRK(3,NIMAX),GPUPHI(NIMAX),GF(3,NMAX),GFD(3,NMAX),
     &         DTR(NIMAX)
      INTEGER  NXTLST(NMAX),LISTQ(NMAX),NL(20)
      INTEGER  IRR(NMAX),IREG(NMAX),LISTGP(LMAX,NIMAX)
      LOGICAL LOOP,LSTEPM
      SAVE IQ,ICALL,NQ,LQ,LOOP,LSTEPM,STEPM,ISAVE,JSAVE,ISTART,TBH
      DATA IQ,ICALL,LQ,LOOP,LSTEPM,STEPM /0,2,11,.TRUE.,.FALSE.,0.03125/
      DATA ISAVE,JSAVE,ISTART /0,0,0/
      SAVE TLISTQ,TMIN,ICOMP0,JCOMP0,NPACT,GF,GFD
      SAVE NXTLST,LISTQ,IRR,IREG,LISTGP,ISTAT
*     SAVE CPRED,CPRED2,CPRED3
*     DATA CPRED,CPRED2,CPRED3 /0.0D0,0.0D0,0.0D0/
*
*
*       Update quantized value of STEPM for large N (first time only).
      IF (.NOT.LSTEPM.AND.NZERO.GT.1024) THEN
          K = INT((FLOAT(NZERO)/1024.0)**0.333333)
          STEPM = 0.03125D0/2**(K-1)
          LSTEPM = .TRUE.
      END IF
*
*       Open the GPU libraries on each new run (note nnbmax = NN is printed).
      IF (ISTART.EQ.0) THEN
          NN = NTOT + 100
          CALL GPUNB_OPEN(NN)
*       Set larger value for GPUIRR (note further possible increase of NTOT).
          NNN = NTOT + 100
*       Increase NNN further for cold start to deal with many KS.
          IF (QVIR.LT.0.01.AND.TIME.EQ.0.0D0) NNN = NTOT + 500
*       Allow for missing primordial binaries.
          NNN = NNN + NBIN0 - NPAIRS
          CALL GPUIRR_OPEN(NNN,LMAX)
          ISTART = 1
*       Define parameter for predicting active particles in library.
          IF (N.LE.5000) THEN
              NPACT = 75
          ELSE IF (N.LE.50000) THEN
              NPACT = 100
          ELSE IF (N.LE.100000) THEN
              NPACT = 150
          ELSE
              NPACT = 200
          END IF
          TBH = TTOT
      END IF
*
*       Search for high velocities after escape or KS/chain termination.
  999 IF (KZ(37).GT.0.AND.(IPHASE.EQ.-1.OR.IPHASE.GE.2)) THEN
          CALL HIVEL(0)
      END IF
*
*       Initialize new force times and predict to previous TIME.
      IF (IPHASE.EQ.1) THEN
*       Treat case of new KS with components from ICOMP0 & JCOMP0.
          I = ICOMP0
*       Avoid updating unchanged locations.
 1000     IF (I.GE.IFIRST) THEN
              TNEW(I) = T0(I) + STEP(I)
              TPRED(I) = -1.0
              CALL JPRED(I)
              CALL GPUIRR_SET_JP(I,X0(1,I),X0DOT(1,I),F(1,I),FDOT(1,I),
     &                                                BODY(I),T0(I))
          END IF
*       Select second component or new c.m. (not connected with ICOMP0).
          IF (I.EQ.ICOMP0) THEN
              I = JCOMP0
              GO TO 1000
          ELSE IF (I.EQ.JCOMP0) THEN
              I = NTOT
              GO TO 1000
          END IF
!$omp parallel do private(J)
          DO 1010 J = IFIRST,NTOT
              CALL GPUIRR_SET_LIST(J,LIST(1,J))
 1010     CONTINUE
!$omp end parallel do
*
*       Remove ICOMP0 & JCOMP0 from LISTQ and add NTOT.
          CALL REPAIR(ICOMP0,JCOMP0,NTOT,0,NQ,LISTQ,TMIN)
*       Check KS termination (locations IFIRST & IFIRST + 1).
      ELSE IF (IPHASE.EQ.2) THEN
*       Update relevant variables for the KS components and later c.m.
          I1 = IFIRST
          I2 = I1 + 1
 1015     DO 1030 I = I1,I2
              TNEW(I) = T0(I) + STEP(I)
              TPRED(I) = -1.0
              CALL JPRED(I)
              CALL GPUIRR_SET_JP(I,X0(1,I),X0DOT(1,I),F(1,I),FDOT(1,I),
     &                                                BODY(I),T0(I))
 1030     CONTINUE
*
*       Include all the more recent c.m. bodies.
          IF (I1.EQ.IFIRST) THEN
              I1 = N + KSPAIR
              I2 = NTOT
              GO TO 1015
*       Note loop is ignored for case of last c.m. (KSPAIR = NPAIRS + 1).
          END IF
*
*       Re-send all neighbour lists using parallel directive (cheap loop).
!$omp parallel do private(I)
          DO 1035 I = IFIRST,NTOT
              CALL GPUIRR_SET_LIST(I,LIST(1,I))
 1035     CONTINUE
!$omp end parallel do
*
*       Add two first single particles to LISTQ and remove terminated c.m.
          CALL REPAIR(N+KSPAIR,0,IFIRST,IFIRST+1,NQ,LISTQ,TMIN)
      END IF
*
*       Update all SET_JP & SET_LIST except for frequent IPHASE = 1 or 2.
      IF (IPHASE.LE.0.OR.IPHASE.GE.3) THEN
*       Include at TIME = 0, CHAIN (7, 8), COLL & COAL, escape & MERGE/RESET.
!$omp parallel do private(I)
*       Note IPHASE = 3 also after ENFORCED KS in ADJUST (if no escape).
          DO 1040 I = IFIRST,NTOT
              CALL GPUIRR_SET_JP(I,X0(1,I),X0DOT(1,I),F(1,I),FDOT(1,I),
     &                                                BODY(I),T0(I))
              CALL GPUIRR_SET_LIST(I,LIST(1,I))
*       Initialize end-point of new times and predict all at previous TIME.
              TNEW(I) = T0(I) + STEP(I)
              TPRED(I) = -1.0
              CALL JPRED(I)
*       Note that this prediction is strictly not necessary.
 1040     CONTINUE
!$omp end parallel do
*       Prescribe level search on return, except for new and terminated KS.
          LOOP = .TRUE.
          TLISTQ = TIME
      END IF
*
*       Reset control & regularization indicators.
      IPHASE = 0
      IKS = 0
      TPREV = TIME
*       Take close encounter step as typical lower value for time-step list.
      CALL STEPK(DTMIN,DTM)
*
*       Determine level for the smallest step (ignore extreme values).
      LQS = 20
      DO 1050 L = 6,20
          IF (DTM.EQ.DTK(L)) THEN
              LQS = L
          END IF
 1050 CONTINUE
*
*       Specify upper level for optimized membership and reset IQ.
      LQB = LQS - 8
      IF (IQ.LT.0) ICALL = 0
      IQ = 0
*
*       Check updating new list of block steps with T0 + STEP =< TLISTQ.
    1 ICALL = ICALL + 1
*       Reset TMIN second & third time after change to catch new chain step.
      IF (TIME.GE.TLISTQ.OR.ICALL.LE.3) THEN
*       Update interval by optimization at major times (sqrt of N-NPAIRS).
          IF (DMOD(TLISTQ,2.0D0).EQ.0.0D0.OR.LOOP) THEN
              LOOP = .FALSE.
              DO 10 L = 1,20
                  NL(L) = 0
   10         CONTINUE
              DO 14 I = IFIRST,NTOT
*       Count steps at five different levels for the smallest values.
                  DO 12 L = LQB,LQS
                      IF (STEP(I).LT.DTK(L)) NL(L) = NL(L) + 1
   12             CONTINUE
   14         CONTINUE
              NLSUM = 0
*       Determine interval by summing smallest steps until near sqrt(N-N_b).
              NSQ = INT(SQRT(FLOAT(N - NPAIRS)))
              LQ = LQS
              DO 15 L = LQS,LQB,-1
                  NLSUM = NLSUM + NL(L)
                  IF (NLSUM.LE.NSQ) LQ = L
   15         CONTINUE
*             WRITE (6,16)  TIME+TOFF,NQ,NLSUM,LQ,(NL(K),K=LQB,LQS)
*  16         FORMAT (' LEVEL CHECK:    T NQ NLSUM LQ NL  ',
*    &                                  F9.3,3I5,2X,7I4)
          END IF
*
*       Increase interval by optimized value.
          NQ = 0
          TMIN = 1.0D+10
   18     TLISTQ = TLISTQ + DTK(LQ)
          DO 20 I = IFIRST,NTOT
              IF (TNEW(I).LE.TLISTQ) THEN
                  NQ = NQ + 1
                  LISTQ(NQ) = I
                  TMIN = MIN(TNEW(I),TMIN)
              END IF
   20     CONTINUE
*       Increase interval in rare case of zero membership.
          IF (NQ.EQ.0) GO TO 18
*       Make a slight adjustment for high levels and small membership.
          IF (LQ.LE.15.AND.NQ.LE.2) LQ = LQ - 1
      END IF
*
*     TTT = TIME     ! Used for profiling (needs wtime.o).
*     TLAST = TIME   ! Activate on negative time test.
*
*       Find all particles in next block (TNEW = TMIN) and set TIME.
      CALL  INEXT(NQ,LISTQ,TMIN,NXTLEN,NXTLST)
*
*       Set new time and save block time (for regularization terminations).
      I = NXTLST(1)
      TIME = T0(I) + STEP(I)
      TBLOCK = TIME
*
*       Include diagnostics for negative TIME and block-step diagnostics.
*     IF (TIME.LT.TLAST.AND.TIME.LT.TLISTQ) THEN
*     WRITE (6,1300) NXTLEN, NQ, TIME, TIME-TLAST,STEP(I)
*1300 FORMAT (' NEGATIVE!    LEN NQ T T-TL S ',2I6,F10.5,1P,2E10.2)
*     CALL FLUSH(6)
*     END IF
*     WRITE (6,22)  I, NXTLEN, NSTEPU, NSTEPI, TIME, STEP(I), STEPR(I)
*  22 FORMAT (' INTGRT   I LEN #U #I T S SR  ',2I6,2I11,F10.4,1P,2E10.2)
*     CALL FLUSH(6)
*
*       Terminate on small irregular time-step (means problems).
      IF (STEP(I).LT.1.0D-11) THEN
          WRITE (6,24)  I, NAME(I), NXTLEN, NSTEPR, STEP(I), STEPR(I)
   24     FORMAT (' SMALL STEP!!    I NAME LEN #R SI SR ',
     &                              3I6,I11,1P,2E10.2)
          STOP
      END IF
*
*     TT2 = DBLTIM()
*     CPRED3 = CPRED3 + (TT2 - TT1)
*       Re-determine list if current time exceeds boundary.
      IF (TIME.GT.TLISTQ) GO TO 1
*
*       Check option for advancing interstellar clouds.
      IF (KZ(13).GT.0) THEN
          CALL CLINT
      END IF
*
*       Check optional integration of cluster guiding centre.
      IF (KZ(14).EQ.3.OR.KZ(14).EQ.4) THEN
          IF (KZ(14).EQ.3.AND.DMOD(TIME,STEPX).EQ.0.0D0) THEN
              CALL GCINT
          END IF
*       Include mass loss by gas expulsion (Kroupa et al. MN 321, 699).
          IF (MPDOT.GT.0.0D0.AND.TIME + TOFF.GT.TDELAY) THEN
              CALL PLPOT1(PHI1)
              MP = MP0/(1.0 + MPDOT*(TIME + TOFF - TDELAY))
*       Replace by exponential mass loss for faster decrease.
*             DT = TIME + TOFF - TDELAY
*             MP = MP0*EXP(-MPDOT*DT)
              CALL PLPOT1(PHI2)
*       Add differential correction for energy conservation.
              EMDOT = EMDOT + (PHI1 - PHI2)
          END IF
      END IF
*
*       Include commensurability test (may be suppressed if no problems).
*     IF (DMOD(TIME,STEP(I)).NE.0.0D0) THEN
*         WRITE (6,25)  I, NAME(I), NSTEPI, TIME, STEP(I), TIME/STEP(I)
*  25     FORMAT (' DANGER!   I NM # TIME STEP T/DT ',
*    &                        2I6,I11,F12.5,1P,E9.1,0P,F16.4)
*         STOP
*     END IF
*
*       Check for new regularization at end of previous block.
      IF (IKS.GT.0) THEN
          IPHASE = 1
*       Copy the saved KS component indices and time.
          ICOMP = ISAVE
          JCOMP = JSAVE
          TIME = TSAVE
          ICOMP0 = ICOMP
          JCOMP0 = JCOMP
          GO TO 100
      END IF
*
*     TT1 = DBLTIM()
*       Check next adjust time before beginning a new block.
      IF (TIME.GT.TADJ) THEN
          TIME = TADJ
          IPHASE = 3
          GO TO 100
      END IF
*
*       Check output time in case DTADJ & DELTAT not commensurate.
      IF (TIME.GT.TNEXT) THEN
          TIME = TNEXT
          CALL OUTPUT
          GO TO 1
      END IF
*
*       See whether to advance ARchain or KS at first new time.
      IF (TIME.GT.TPREV) THEN
          CALL SUBINT(IQ,I10)
*       Check collision/coalescence indicator.
          IF (IQ.LT.0) GO TO 999
      END IF
*
*       Form lists of candidates for new irregular and regular force.
      NFR = 0
      DO 28 L = 1,NXTLEN
          J = NXTLST(L)
          IF (TNEW(J).GE.T0R(J) + STEPR(J)) THEN
              NFR = NFR + 1
              IREG(NFR) = J
              IRR(L) = J
          ELSE
              IRR(L) = 0
          END IF
   28 CONTINUE
*
*       Decide between predicting <= NPACT active (NFR = 0) or all particles.
      IF (NXTLEN.LE.NPACT.AND.NFR.EQ.0) THEN
*
*       Predict active particles in the GPUIRR library.
          CALL GPUIRR_PRED_ACT(NXTLEN,NXTLST,TIME)
      ELSE
          CALL GPUIRR_PRED_ALL(IFIRST,NTOT,TIME)
          NNPRED = NNPRED + 1
*!$omp parallel do private(S, S1, S2)
*         DO 40 J = IFIRST,NTOT
*             IF (BODY(J).EQ.0.0D0) GO TO 40
*             S = TIME - T0(J)
*             S1 = 1.5*S
*             S2 = 2.0*S
*             X(1,J) = ((FDOT(1,J)*S + F(1,J))*S +X0DOT(1,J))*S +X0(1,J)
*             X(2,J) = ((FDOT(2,J)*S + F(2,J))*S +X0DOT(2,J))*S +X0(2,J)
*             X(3,J) = ((FDOT(3,J)*S + F(3,J))*S +X0DOT(3,J))*S +X0(3,J)
*             XDOT(1,J) = (FDOT(1,J)*S1 + F(1,J))*S2 + X0DOT(1,J)
*             XDOT(2,J) = (FDOT(2,J)*S1 + F(2,J))*S2 + X0DOT(2,J)
*             XDOT(3,J) = (FDOT(3,J)*S1 + F(3,J))*S2 + X0DOT(3,J)
*  40     CONTINUE
*!$omp end parallel do
      END IF
*
*       Save new time (output time at TIME > TADJ) and increase # blocks.
      TPREV = TIME
      NBLOCK = NBLOCK + 1
      TMIN = 1.0D+10
      IKS0 = IKS
*
*       Predict chain variables and perturbers at new block-time.
      IF (NCH.GT.0) THEN
          CALL JPRED(ICH)
          CALL XCPRED(2)
      END IF
*
*       Evaluate all irregular forces & derivatives in the GPUIRR library.
*     DO 46 II = 1,NXTLEN
*         I = NXTLST(II)
*         CALL GPUIRR_FIRR(I,GF(1,II),GFD(1,II))
*  46 CONTINUE
      CALL GPUIRR_FIRR_VEC(NXTLEN,NXTLST,GF,GFD)
*
*       Choose between standard and parallel irregular integration.
      IF (NXTLEN.LE.NPMAX) THEN
*
*       Correct the irregular steps sequentially.
      DO 48 II = 1,NXTLEN
          I = NXTLST(II)
*       Advance the irregular step (no copy of X0 to GPUIRR needed here).
          CALL NBINT(I,IKS,IRR(II),GF(1,II),GFD(1,II))
*         CALL GPUIRR_SET_JP(I,X0(1,I),X0DOT(1,I),F(1,I),FDOT(1,I),
*    &                                            BODY(I),T0(I))
*
*       Save indices and TIME of first KS candidates in the block.
          IF (IKS0.EQ.0.AND.IKS.GT.0) THEN
              ISAVE = ICOMP
              JSAVE = JCOMP
              TSAVE = TIME
              IKS0 = IKS
          END IF
   48 CONTINUE
*
      ELSE
*       Initialize array for repeated cases to ensure thread-safety.
      DO 49 II = 1,NXTLEN
          ISTAT(II) = -1
   49 CONTINUE
*       Perform irregular correction in parallel (suppressed currently).
*!$omp parallel do private(II, I)
      DO 50 II = 1,NXTLEN
          I = NXTLST(II)
          CALL NBINTP(I,IRR(II),GF(1,II),GFD(1,II),ISTAT(II))
   50 CONTINUE
*!$omp end parallel do
*
*       Correct the irregular steps sequentially.
      IPHASE = 0
      IKS = 0
      DO 500 II = 1,NXTLEN
          IF (ISTAT(II).GT.0) THEN
              I = NXTLST(II)
*       Correct exceptional irregular steps in serial.
              CALL NBINT(I,IKS,IRR(II),GF(1,II),GFD(1,II))
*     WRITE (6,490)  TIME, IKS, NAME(I), STEP(I)
* 490 FORMAT (' INTGRT!     T IKS NM SI ',F12.4,I4,I7,1P,E10.2)
          NSTEPQ = NSTEPQ + 1
          END IF
  500 CONTINUE
      END IF
      NSTEPI = NSTEPI + NXTLEN
*
*       Check regular force updates (NFR members on block-step #NBLCKR).
      IF (NFR.GT.0) THEN
      NBLCKR = NBLCKR + 1
      NN = NTOT - IFIRST + 1
*     TT3 = DBLTIM()
*
*       Predict all particles (except TPRED=TIME) in C++ on host.
      CALL CXVPRED(IFIRST,NTOT,TIME,T0,X0,X0DOT,F,FDOT,X,XDOT,TPRED)
*       Note it would be wrong to predict TPRED=TIME by corrected X0 & X0DOT.
*
*     TT4 = DBLTIM()
*     CPRED = CPRED + (TT4 - TT3)
*     IF (DMOD(TIME,2.0D0).EQ.0.0D0) WRITE (6,540)  CPRED
* 540 FORMAT (' TIMING CXVPRED  ',1P,E10.2)
*       Send all single particles and c.m. bodies to the GPU.
      CALL GPUNB_SEND(NN,BODY(IFIRST),X(1,IFIRST),XDOT(1,IFIRST))
*
*       Perform regular force loop.
      NOFL(1) = 0
      NOFL2 = 0
      JNEXT = 0
      DO 55 II = 1,NFR,NIMAX
  550     NI = MIN(NFR-JNEXT,NIMAX)
*       Copy neighbour radius, STEPR and state vector for each block.
!$omp parallel do private(LL, I, K)
          DO 52 LL = 1,NI
              I = IREG(JNEXT+LL)
              H2I(LL) = RS(I)**2
              DTR(LL) = STEPR(I)
              DO 51 K = 1,3
                  XI(K,LL) = X(K,I)
                  VI(K,LL) = XDOT(K,I)
   51         CONTINUE
   52     CONTINUE
!$omp end parallel do
*
*       Evaluate forces, derivatives and neighbour lists for new block.
          CALL GPUNB_REGF(NI,H2I,DTR,XI,VI,GPUACC,GPUJRK,GPUPHI,LMAX,
     &                                                   NBMAX,LISTGP)
*       Copy neighbour lists from the GPU after overflow check.
          DO 54 LL = 1,NI
              I = IREG(JNEXT + LL)
              NNB = LISTGP(1,LL)
*       Repeat last block with reduced RS(I) on NNB < 0 (at end of loop).
              IF (NNB.LT.0) THEN
                  RI2 = (X(1,I)-RDENS(1))**2 + (X(2,I)-RDENS(2))**2 +
     &                                         (X(3,I)-RDENS(3))**2
                  WRITE (41,556)  NSTEPR, NAME(I), LIST(1,I), NNB,
     &                            RS(I), SQRT(RI2)
  556             FORMAT (' OVERFLOW!   #R NAME NB0 NB RS ri ',
     &                                  I11,I6,2I5,2F8.3)
                  CALL FLUSH(41)
                  NOFL(1) = NOFL(1) + 1
                  RS(I) = 0.9*RS(I)
                  H2I(LL) = RS(I)**2
                  NOFL2 = NOFL2 + 1
              END IF
   54     CONTINUE
          IF (NOFL2.GT.0) THEN
              NOFL2 = 0
              GO TO 550
           END IF
!$omp parallel do private(LL, I, ITEMP, NNB, L1, L)
          DO 56 LL = 1,NI
              I = IREG(JNEXT + LL)
              NNB = LISTGP(1,LL)
              L1 = 1
              DO 53 L = 2,NNB+1
*       Note GPU address starts from 0 (hence add IFIRST to neighbour list).
                  ITEMP = LISTGP(L,LL) + IFIRST
                  IF (ITEMP.NE.I) THEN
                      L1 = L1 + 1
                      LISTGP(L1,LL) = ITEMP
                  END IF
   53         CONTINUE
              LISTGP(1,LL) = L1 - 1
              CALL GPUIRR_SET_LIST(I,LISTGP(1,LL))
   56     CONTINUE
!$omp end parallel do
*
*       Evaluate current irregular forces by vector procedure.
          CALL GPUIRR_FIRR_VEC(NI,IREG(II),GF(1,1),GFD(1,1))
*       NB! Note suppression of parallel procedure here and for nbintp.f.
!$omp parallel do private(I, LX)
          DO 57 LL = 1,NI
              I = IREG(JNEXT+LL)
*       Send new irregular force and perform correction.
*             CALL GPUIRR_FIRR(I,GF(1,LL),GFD(1,LL))
              CALL GPUCOR(I,XI(1,LL),VI(1,LL),GPUACC(1,LL),GPUJRK(1,LL),
     &                               GF(1,LL),GFD(1,LL),LISTGP(1,LL),LX)
*       Update neighbour lists in GPUIRR library (only if changed: LX > 0).
              IF (LX.GT.0) THEN
                  CALL GPUIRR_SET_LIST(I,LIST(1,I))
                  NBPRED = NBPRED + 1
              END IF
*       Note possible errors in the potential when using predicted values.
*             POT = POT + BODY(I)*GPUPHI(LL)
   57     CONTINUE
!$omp end parallel do
          JNEXT = JNEXT + NI
   55 CONTINUE
*
*       Accumulate the sum of overflows (NOFL(1) holds current number).
      NOFL(2) = NOFL(2) + NOFL(1)
      NSTEPR = NSTEPR + NFR
*
      END IF
*
*       Determine next block time (note STEP may shrink in GPUCOR).
      DO 350 L = 1,NXTLEN
          I = NXTLST(L)
          IF (TNEW(I).LT.TMIN) THEN
              TMIN = TNEW(I)
          END IF
  350 CONTINUE
*
*       Copy current coordinates & velocities from corrected values, IQ.NE.0.
      IF (IKS.GT.0.OR.IQ.NE.0.OR.TIME.GE.TADJ.OR.TIME.GE.TNEXT.OR.
     &   (KZ(19).GE.3.AND.DMOD(TIME,STEPX).EQ.0.0D0)) THEN
*       Note: need copy X & XDOT at output (skip in XVPRED; also cf. #31 >0).
!$omp parallel do private(I, L, K)
      DO 360 L = 1,NXTLEN
          I = NXTLST(L)
          DO 58 K = 1,3
              X(K,I) = X0(K,I)
              XDOT(K,I) = X0DOT(K,I)
   58     CONTINUE
  360 CONTINUE
!$omp end parallel do
      END IF
*
*       Send corrected active particles to GPUIRR library.
!$omp parallel do private(I, L)
      DO 60 L = 1,NXTLEN
          I = NXTLST(L)
          CALL GPUIRR_SET_JP(I,X0(1,I),X0DOT(1,I),F(1,I),FDOT(1,I),
     &                                            BODY(I),T0(I))
   60 CONTINUE
!$omp end parallel do
*
*     TT2 = DBLTIM()
*     CPRED2 = CPRED2 + (TT2 - TT1)
*     IF (TIME.EQ.TCRIT) WRITE (6,380)  CPRED2, TT2, CPRED, CPRED3
* 380 FORMAT (' TIMING     CPRED2 TT2 CPRED CPRED3 ',1P,4E12.2)
*
*       Check integration of tidal tail members.
      IF (NTAIL.GT.0) THEN
*       Allow large quantized interval with internal iteration.
          IF (DMOD(TIME,0.25D0).EQ.0.0D0) THEN
              DO 65 J = ITAIL0,NTTOT
                  IF (TNEW(J).LE.TIME) THEN
                      CALL NTINT(J)
                  END IF
   65         CONTINUE
          END IF
      END IF
*
*       Exit on KS termination, new multiple regularization or merger.
      IF (IQ.NE.0) THEN
          NBPREV = 0
          IF (IQ.GE.4.AND.IQ.NE.7) THEN
              CALL DELAY(IQ,-1)
          ELSE
*       Ensure correct KS index (KSPAIR may denote second termination).
              KSPAIR = KVEC(I10)
              IPHASE = IQ
          END IF
          GO TO 100
      END IF
*
*       Perform optional check on high-velocity particles at major times.
      IF (KZ(37).GT.0.AND.LISTV(1).GT.0) THEN
          IF (DMOD(TIME,STEPM).EQ.0.0D0) THEN
              CALL SHRINK(TMIN)
              IF (LISTV(1).GT.0) THEN
                  CALL HIVEL(-1)
              END IF
          END IF
      END IF
*
*       Check optional mass loss time at end of block-step.
      IF (KZ(19).GT.0) THEN
*       Delay until time commensurate with 100-year step (new polynomials).
          IF (TIME.GT.TMDOT.AND.DMOD(TIME,STEPX).EQ.0.0D0) THEN
              IF (KZ(19).GE.3) THEN
                  CALL MDOT
              ELSE
                  CALL MLOSS
              END IF
              IF (IPHASE.LT.0) GO TO 999
          END IF
      END IF
*
*       Include optional plotting of single BH orbits (1 or 2).
      IF (KZ(45).GT.0.AND.TBH.LT.TIME+TOFF) THEN
          CALL BHPLOT
*       Update time interval (try 10 points per time unit).
          TBH = TBH + 1.0D-01
      END IF
*
*       Advance counters and check timer & optional COMMON save (NSUB = 0).
      NTIMER = NTIMER + NXTLEN
      IF (NTIMER.LT.NMAX) GO TO 1

      NTIMER = 0
      NSTEPS = NSTEPS + NMAX
*
      IF (NSTEPS.GE.10*N.AND.N.GT.1000.AND.NSUB.EQ.0) THEN
          NSTEPS = 0
          IF (KZ(1).EQ.3) CALL MYDUMP(1,1)
      END IF
*
*       Check option for general binary search.
      IF (KZ(4).GT.0.AND.TIME - TLASTS.GT.DELTAS) THEN
          CALL EVOLVE(0,0)
      END IF
*
*       Include facility for termination of run (create dummy file STOP).
      OPEN (99,FILE='STOP',STATUS='OLD',FORM='FORMATTED',IOSTAT=IO)
      IF (IO.EQ.0) THEN
          CLOSE (99)
          IF (NSUB.EQ.0)  WRITE (6,70)
   70     FORMAT  (/,9X,'TERMINATION BY MANUAL INTERVENTION')
          CPU = 0.0
      END IF
*
*       Repeat cycle until elapsed computing time exceeds the limit.
      CALL CPUTIM(TCOMP)
      IF (TCOMP.LT.CPU) GO TO 1
*
*       Do not terminate during triple, quad or chain regularization.
      IF (NSUB.GT.0) THEN
*       Specify zero step to enforce termination.
          DO 75 L = 1,NSUB
              STEPS(L) = 0.0D0
   75     CONTINUE
          NTIMER = NMAX
          GO TO 1
      END IF
*
*       Obtain elapsed wall-clock time (hours, minutes & seconds).
      CALL WTIME(IHOUR,IMIN,ISEC)
      SECS = 3600.0*IHOUR + 60.0*IMIN + ISEC
      WTOT = WTOT + SECS - WTOT0
      WTOT0 = SECS
*
*       Terminate run with optional COMMON save.
      IF (KZ(1).GT.0) THEN
          CPUTOT = CPUTOT + TCOMP - CPU0
          WT = WTOT/3600.0
          CALL MYDUMP(1,1)
          WRITE (6,80)  TIME+TOFF, TCOMP, CPUTOT/60.0, ERRTOT, DETOT, WT
   80     FORMAT (/,9X,'COMMON SAVED AT TIME =',F8.2,'  TCOMP =',F7.1,
     &                 '  CPUTOT =',F6.1,'  ERRTOT =',F10.6,
     &                 '  DETOT =',F10.6,'  WTOT =',F7.1)
      END IF
*
*       Close GPU & GPUIRR library and stop.
      CALL GPUNB_CLOSE
      CALL GPUIRR_CLOSE
      STOP
*
*       Set current global time.
  100 TTOT = TIME + TOFF
*
      RETURN
*
      END


MODULE params_model

USE common, ONLY: r_size

IMPLICIT NONE

PUBLIC

  ! Now definable via namelist at runtime:

  ! MOM4 ncep2012 tripolar converted to spherical
#ifdef DYNAMIC
  INTEGER :: nlon=720
  INTEGER :: nlat=410
  INTEGER :: nlev=5
#else
  INTEGER,PARAMETER :: nlon=720
  INTEGER,PARAMETER :: nlat=410
  INTEGER,PARAMETER :: nlev=5   ! These are the different ice thicknesss categories:
                                ! (0-0.1, 0.1-0.3, 0.3-0.7, 0.7-1.1, and > 1.1 m)
#endif

  INTEGER,PARAMETER :: ilev_sfc=1
!
  INTEGER,PARAMETER :: nv3d=5
  INTEGER,PARAMETER :: nv4d=0 ! x,y,z                !(OCEAN) STEVE: add t,x,y,z,id for DRIFTERS
  INTEGER,PARAMETER :: nv2d=1 !STEVE: update when adding ui and vi -> nv2d=3
!
  ! Initialize via subroutine below:
  INTEGER,SAVE :: nij0           ! Number of gridpoints handled by myrank processor
  INTEGER,SAVE :: nlevall        ! Total number of variables and levels (3d + 2d)
  INTEGER,SAVE :: ngpv           ! Total number of gridpoints, including nij0*nlevall

! Placeholders needed by letkf_tools.f90 to compile:
  INTEGER,PARAMETER :: iv3d_t   = -1
  INTEGER,PARAMETER :: iv2d_mld = -1

!
! 3D Variables:
  INTEGER,PARAMETER :: iv3d_hs=1
  INTEGER,PARAMETER :: iv3d_hi=2
  INTEGER,PARAMETER :: iv3d_t1=3
  INTEGER,PARAMETER :: iv3d_t2=4
  INTEGER,PARAMETER :: iv3d_ps=5    ! 3D part size, from restart file levels 2-nlev+1
! 2D Variables:
  INTEGER,PARAMETER :: iv2d_cn=1    ! 2D ice concentration as measured
  INTEGER,PARAMETER :: iv2d_ui=2    ! 2D ice drift (zonal)
  INTEGER,PARAMETER :: iv2d_vi=3    ! 2D ice drift (meridional)

  REAL(r_size) :: obs_noise_coeff = 0.01  !(SIS)  !STEVE: can set in namelist

! INTEGER,PARAMETER :: iv4d_x=1                !(OCEAN) (DRIFTERS)
! INTEGER,PARAMETER :: iv4d_y=2                !(OCEAN) (DRIFTERS)
! INTEGER,PARAMETER :: iv4d_z=3                !(OCEAN) (DRIFTERS)

  !
  ! Elements
  !
  CHARACTER(20), SAVE :: element(nv3d+nv2d+nv4d)

  !For input/output model files:
  CHARACTER(16) :: basefile = 'ice_model.res.nc'

! CHARACTER(14) :: SSHclm_file = 'aEtaCds9399.nc'
! CHARACTER(32) :: ts_basefile = 'ocean_temp_salt.res.nc'
! CHARACTER(32) :: uv_basefile = 'ocean_velocity.res.nc'
! CHARACTER(32) :: sf_basefile = 'ocean_sbc.res.nc'
! CHARACTER(32) :: sh_basefile = 'ocean_barotropic.res.nc'
! CHARACTER(32) :: hs_basefile = 'ocean_TS.nc'

  ! For grid_spec.nc data file:
  CHARACTER(12) :: gridfile = 'grid_spec.nc'

  ! variable names in gridfile:
  CHARACTER(8) :: grid_lon_name = 'grid_x_T'
  CHARACTER(8) :: grid_lat_name = 'grid_y_T'
  CHARACTER(2) :: grid_lev_name = 'zt'
  CHARACTER(3) :: grid_lon2d_name = 'x_T'
  CHARACTER(3) :: grid_lat2d_name = 'y_T'
  CHARACTER(3) :: grid_wet_name = 'wet'
  CHARACTER(10):: grid_kmt_name = 'num_levels'

  ! variable names in diag file:
  CHARACTER(6) :: diag_hs_name = 'h_snow'
  CHARACTER(5) :: diag_hi_name = 'h_ice'
  CHARACTER(6) :: diag_t1_name = 't_ice1'
  CHARACTER(6) :: diag_t2_name = 't_ice2'
  CHARACTER(9) :: diag_ps_name = 'part_size'

  ! variable names in restart file:
  CHARACTER(6) :: rsrt_hs_name = 'h_snow'
  CHARACTER(5) :: rsrt_hi_name = 'h_ice'
  CHARACTER(6) :: rsrt_t1_name = 't_ice1'
  CHARACTER(6) :: rsrt_t2_name = 't_ice2'
  CHARACTER(9) :: rsrt_ps_name = 'part_size'

  ! Bounds checking (for output by common_mom4.f90::write_restart)
  LOGICAL :: do_physlimit=.true.
  REAL(r_size) :: max_t = 40.0d0 ! ÂC
  REAL(r_size) :: min_t = -4.0d0 ! ÂC
  REAL(r_size) :: max_s = 50.0d0 ! psu
  REAL(r_size) :: min_s =  0.0d0 ! psu

  !STEVE: needed for letkf.f90 to compile
  CHARACTER(14) :: SSHclm_file = 'aEtaCds9399.nc'

  LOGICAL,SAVE :: params_model_initialized = .false.

CONTAINS

SUBROUTINE initialize_params_model

  IMPLICIT NONE

  if (params_model_initialized) then
    WRITE(6,*) "initialize_params_model:: already initialized, RETURNING..."
    RETURN
  endif

  nij0=nlon*nlat
  nlevall=nlev*nv3d+nv2d
  ngpv=nij0*nlevall

  !
  ! Elements
  !
  element(iv3d_hs) = 'snow layer height'
  element(iv3d_hi) = ' ice layer height'
  element(iv3d_t1) = ' ice layer 1 temp'
  element(iv3d_t2) = ' ice layer 2 temp'

  params_model_initialized = .true.

END SUBROUTINE initialize_params_model

END MODULE params_model


*
*     -------------------------------------------------------------
*      T W O P A R T I C L E 3 3
*     -------------------------------------------------------------
*                                                                  *
*     THIS PACKAGE DETERMINES THE VALUES OF MATRIX ELEMENTS        *
*     OF TWO PARTICLE OPERATOR IN CASE :       N'1 = N1 - 1        *
*                                              N'2 = N2 + 1        *
*                                                                  *
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
      SUBROUTINE TWOPARTICLE33(IA,IB,IC,IIA,IIB,IIC,IID)
      IMPLICIT DOUBLEPRECISION (A-H,O-Z)
      COMMON/MEDEFN/IHSH,NJ(16),LJ(16),NOSH1(16),NOSH2(16),J1QN1(31,3),
     :     J1QN2(31,3),IJFUL(16)
      COMMON/TRK/BD1(3),BD2(3),BK1(3),BK2(3),
     *ID1(7),ID2(7),IK1(7),IK2(7)
      COMMON/TRK2/BD3(3),BD4(3),BK3(3),BK4(3),
     *ID3(7),ID4(7),IK3(7),IK4(7)
      COMMON/PERMAT/IRS(2,2),IRL(20,20),RS(2,2),RL(20,20)
      COMMON/KAMPAS/ IW1(2,20),IW2(2,20),IWAA(2,2,20,20),
     :RW1(2,20),RW2(2,20),RWAA(2,2,20,20)
      COMMON /CASEOP/ IOCASE
      EXTERNAL TWO33A,TWO33B
      IF(IHSH.LE.2)RETURN
      CALL HIBFF(IA,IB,IC,IA,3)
      IF(ITTK(1,IK1(6),ID1(6)).EQ.0) RETURN
      IF(ITTK(1,IK2(6),ID2(6)).EQ.0) RETURN
      IF(IABS(IK3(6)-ID3(6)).GT.2) RETURN
      IF(ITTK(2*IK1(3),IK1(5),ID1(5)).EQ.0) RETURN
      IF(ITTK(2*IK2(3),IK2(5),ID2(5)).EQ.0) RETURN
      IF(IABS(IK3(5)-ID3(5)).GT.4*IK3(3)) RETURN
      DO 3 I1=1,2
        DO 4 I2=1,2
	  IRS(I1,I2)=0
    4   CONTINUE
    3 CONTINUE
      DO 5 I1=1,20
	IW1(1,I1)=0
	IW1(2,I1)=0
        DO 6 I2=1,20
	  IRL(I1,I2)=0
    6   CONTINUE
    5 CONTINUE
      IF(IOCASE.EQ.1) THEN
* Spin-Spin operator
        IP=ITREXG2(LJ(IA),LJ(IB),LJ(IC),LJ(IC),IKK)+1
      ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
        IP=ITREXG(LJ(IA),LJ(IB),LJ(IC),LJ(IC),IKK)+1
      ENDIF
      IF(IKK.GT.0) THEN
        IG=IP+IKK-1
        DO 1 I=IP,IG
          KL=I-1
*
          IF(IOCASE.EQ.1) THEN
* Spin-spin operator
            CALL SSC(IG,KL,IA,IB,IC,IC,IB,IC,IA,IC,KL,TWO33A)
          ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
            CALL SOOC(IG,KL,IA,IB,IC,IC,IB,IC,IA,IC,KL,TWO33A)
          ENDIF
*
    1   CONTINUE
      ENDIF
      IF(IOCASE.EQ.1) THEN
* Spin-Spin operator
        IP=ITREXG2(LJ(IA),LJ(IC),LJ(IB),LJ(IC),IKK)+1
      ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
        IP=ITREXG(LJ(IA),LJ(IC),LJ(IB),LJ(IC),IKK)+1
      ENDIF
      IF(IKK.LE.0)RETURN
      IG=IP+IKK-1
      DO 2 I=IP,IG
        KL=I-1
        IF(IOCASE.EQ.1) THEN
* Spin-spin operator
          CALL SSC(IG,KL,IA,IB,IC,IC,IC,IB,IA,IC,KL,TWO33B)
        ELSEIF(IOCASE.EQ.2) THEN
* Spin-other-orbit operator
          CALL SOOC(IG,KL,IA,IB,IC,IC,IC,IB,IA,IC,KL,TWO33B)
	ENDIF
    2 CONTINUE
      RETURN
      END