! <casrc.f90 - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!* EPISODE - An urban-scale air quality model
!* ==========================================
!* Copyright (C) 2018  NILU - Norwegian Institute for Air Research
!*                     Instituttveien 18
!*                     PO Box 100
!*                     NO-2027 Kjeller
!*                     Norway
!*
!*                     Contact persons: Gabriela Sousa Santos - gss@nilu.no
!*                                      Paul Hamer - pdh@nilu.no
!*
!* Unless explicitly acquired and licensed from Licensor under another license,
!* the contents of this file are subject to the Reciprocal Public License ("RPL")
!* Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!* allowed by the RPL, and You may not copy or use this file in either source code
!* or executable form, except in compliance with the terms and conditions of the RPL.
!*
!* All software distributed under the RPL is provided strictly on an "AS IS" basis,
!* WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!* DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!* MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!* See the RPL for specific language governing rights and limitations under the RPL.
!*
!* ==========================================
!* The dispersion model EPISODE (Grønskei et. al., 1993; Larssen et al., 1994;
!* Walker et al., 1992, 1999; Slørdal et al., 2003, 2008) is an Eulerian grid model
!* with embedded subgrid models for calculations of pollutant concentrations resulting
!* from different types of sources (area-, line- and point sources). EPISODE solves the
!* time dependent advection/-diffusion equation on a 3 dimensional grid.
!* Finite difference numerical methods are applied to integrate the solution forward in time.
!* It also includes extensions as the implementation of a simplified EMEP photochemistry
!* scheme for urban areas (Walker et al. 2004) and a scheme for Secondary Organic Aerosol
!* implemented by Håvard Slørdal
!*
!* Grønskei, K.E., Walker, S.E., Gram, F. (1993) Evaluation of a model for hourly spatial
!*    concentrations distributions. Atmos. Environ., 27B, 105-120.
!* Larssen, S., Grønskei, K.E., Gram, F., Hagen, L.O., Walker, S.E. (1994) Verification of
!*    urban scale time-dependent dispersion model with sub-grid elements in Oslo, Norway.
!*    In: Air poll. modelling and its appl. X. New York, Plenum Press.
!* Slørdal, L.H., McInnes, H., Krognes, T. (2008): The Air Quality Information System AirQUIS.
!*    Info. Techn. Environ. Eng., 1, 40-47, 2008.
!* Slørdal, L.H., Walker, S.-E., Solberg, S. (2003) The Urban Air Dispersion Model EPISODE
!*    applied in AirQUIS. Technical Description. NILU TR 12/2003. ISBN 82-425-1522-0.
!* Walker, S.E., Grønskei, K.E. (1992) Spredningsberegninger for on-line overvåking i Grenland.
!*    Programbeskrivelse og brukerveiledning. Lillestrøm,
!*    Norwegian Institute for Air Research (NILU OR 55/92).
!* Walker, S.E., Slørdal, L.H., Guerreiro, C., Gram, F., Grønskei, K.E. (1999) Air pollution
!*    exposure monitoring and estimation. Part II. Model evaluation and population exposure.
!*    J. Environ. Monit, 1, 321-326.
!* Walker, S.-E., Solberg, S., Denby, B. (2003) Development and implementation of a
!*    simplified EMEP photochemistry scheme for urban areas in EPISODE. NILU TR 13/2013.
!*    ISBN 82-425-1524-7
!*****************************************************************************!

      subroutine CASRC

! *** This subroutine distributes the area sources in the model grid.
!
! *** NOTE:   The standard unit for emissions from AirQUIS is [g/s].
!
! *** INPUT:  real qaorig(nc,nx,ny,1:na) ! "na" is indicating the type of area emission field.
! ***                                    ! Most often "na" is 2
!
! ***         "qaorig(nc,nx,ny,1)"       ! Specifies emissions from domestic heating and small industry.
! ***         "qaorig(nc,nx,ny,2)"       ! Specifies emissions from road traffic.
!
! ***         These 2-D fields are distributed vertically into 3_D emission
! ***         fields in the array variable: "qa(nc,nx,ny,nz)"
!
! *** For the runs of 'KPIZ_Large_photochem' and 'KPIZ_Large_photoeq' i.e., the 100 km * 100 km domain
! ***                 (with DX = DY = 5 km) we also specify the temporal distribution  in this routine.
! ***                 This is sort of "hard-coded" below.
!
! *** OUTPUT: real qa(nc,nx,ny,nz)  ! Contains the gridded emission values in units of [g/s].
!
! ----------------------------------------------------------------------------------
! Based on:
! Version Episode 5.5 (May29, 2012) prepared for BB-Stand-Alone
! Original source code of EPISODE by Sam-Erik Walker (NILU)
!
! Sam-Erik Walker
! Norwegian Institute for Air Research (NILU)
! Instituttveien 18 P.O. Box 100
! N-2027 Kjeller, NORWAY
! Tel: +47 63898000 Fax: +47 63898050
! E-mail: sam-erik.walker@nilu.no
!
! ----------------------------------------------------------------------------------
! ----------------------------------------------------------------------------------
! REVISION HISTORY
!
!           2017  M. Karl: Default is attributing the vertical distribution to four sectors:
!                          Domestic heating, Traffic, Other Shipping.
!                          Commented all cases except "Rotterdam"
!    10 Apr 2018  M. Karl: L454-458 Vertical distribution Sector1 (domestic heating): 90:10
!    11 Apr 2018  M. Karl: L469-473 Vertical distribution Sector3 (commercial comb.): 80:20
!
! ----------------------------------------------------------------------------------

      use mod_util
      use mod_main
      use mod_site
      use mod_time
!      use mod_mete     ! Is this used?  HAS TO BE INVOKED IF MET-DEPENDENT GRID EMISSIONS!
      use mod_conc
      use mod_asrc
      use mod_psrc, only : psrcmtype

      implicit none

! *** Function type declaration:
!      integer ILAY    ! This util-Function should be used in order to find the layer index.

! *** Local variables:
      integer :: ia, ic
      integer :: ix, iy, iz
      integer :: ih
      integer :: iiday, iiweek
      integer :: siteid_len

      real    :: tv_qaorig
      real    :: rmax_qa
      real    :: rmin_qa
      real    :: rmax_qaorig_resident, rmax_qaorig_traffic
      real    :: rsum_qaorig_resident, rsum_qaorig_traffic
      real    :: avg_hour_we_tv, avg_hour_wd_tv, avg_day_tv, avg_week_tv

      real    :: test_variable
      real, allocatable :: resident_emis(:,:)
      real, allocatable :: traffic_emis(:,:)
      integer :: dim4_loc(4)

!MSK      logical :: ATTIME
!
! *** ic     - Compound index
! *** ix     - X-direction index
! *** iy     - Y-direction index
! *** iz     - Vertical layer index
! *** ATTIME - If at given date and time then true else false

! *** The "const_scaling(na)" array is to be applied if we need a constant scaling
! *** of some  compound or sector:
! *** NB: This scaling treatment should be moved to: "Subroutine GetAsrcTimeDependentInputData"

      real :: scale_residential = 1.0   ! Sector 1: "Residential":  1.0
      real :: scale_industry    = 1.0   ! Sector 2: "Industry":     3.0
      real :: scale_power       = 1.0   ! Sector 3: "Power":        1.0
      real :: scale_solvent     = 1.0   ! Sector 4: "Solvent":      1.0
      real :: scale_shipping    = 1.0   ! Sector 5: "Shipping":     0.25
      real :: scale_waste       = 1.0   ! Sector 6: "Waste":        1.0
      real :: scale_traffic     = 1.0   ! Sector 7: "Traffic":      3.0

! *** Only scaling the KPIZ_small_domain
!      integer :: ix_select_min = 9
!      integer :: ix_select_max = 12
!      integer :: iy_select_min = 9
!      integer :: iy_select_max = 12

! *** Scaling all of the KPIZ_Large_domain:
      integer :: ix_select_min = 1
      integer :: ix_select_max = 20
      integer :: iy_select_min = 1
      integer :: iy_select_max = 20

      !BRUCE variable for setting the maximum height of the residential distribution
      real :: zdistr_max
      real :: zdistr_min

! *** Zeroing the "mod_conc" array: qa(nc,nx,ny,nz):
      qa = 0.0

      siteid_len = LEN_TRIM(siteid)

! *** Write out som general CASRC information:
      if (messfe) then
        write(messun,*)
        write(messun,'(2A)') 'CASRC: Simulation site name = ',siteid(1:siteid_len)
        write(messun,*)
        write(messun,'(A,I5)') 'CASRC: Hour         = hour = ',hour
        write(messun,'(A,I5)') 'CASRC: Day of week  = dayw = ',dayw
        write(messun,'(A,I5)') 'CASRC: Day of month = daym = ',daym
        write(messun,'(A,I5)') 'CASRC: Day of year  = dayy = ',dayy
        write(messun,'(A,I5)') 'CASRC: Month        = mnth = ',mnth
        write(messun,'(A,I5)') 'CASRC: Year         = year = ',year
        write(messun,*)
        allocate (resident_emis(nx,ny))
        allocate (traffic_emis(nx,ny))
        do ic = 1,nc
          resident_emis = qaorig(ic,:,:,1)
          traffic_emis  = qaorig(ic,:,:,2)
          rsum_qaorig_resident = SUM(resident_emis)
          rsum_qaorig_traffic  = SUM(traffic_emis)
          rmax_qaorig_resident = MAXVAL(resident_emis)
          rmax_qaorig_traffic  = MAXVAL(traffic_emis)
          write(messun,'(A,E12.5,A)') &
       'CASRC-0: Domain sum QAORIG_resident: ',rsum_qaorig_resident,' g/s  '
          write(messun,'(A,E12.5,A)') &
       'CASRC-0: Domain sum QAORIG_traffic:  ',rsum_qaorig_traffic,' g/s  '
          write(messun,*)
          write(messun,'(49X,3A4)') ' IC ','  I ','  J '
          write(messun,'(A,E12.5,A,3I4)') &
       'CASRC-0: Max QAORIG_resident: ',rmax_qaorig_resident,' g/s  ',ic,MAXLOC(resident_emis)
          write(messun,'(A,E12.5,A,4I4)') &
       'CASRC-0: Max QAORIG_traffic:  ',rmax_qaorig_traffic,' g/s  ',ic,MAXLOC(traffic_emis)
          write(messun,*)
        enddo
        deallocate (resident_emis)
        deallocate (traffic_emis)
      endif

! *** START defining the Vertical Distribution of the Asrc Emissions at simulation beginning:
      if (ATTIME(BDAT) .AND. ISH == 1 .AND. ITS == 1) then

! ***   As long as we do not apply the interface SUNROUTINE SendAsrcNewNumberOfAreaSources(pinz,pina)
! ***   (but apply SUNROUTINE SendAsrcNumberOfAreaSources(pina)), we must allocate the arrays below:
        if (.NOT. allocated(hourf))         allocate(hourf(24,2,na))
        if (.NOT. allocated(daywf))         allocate(daywf(7,na))
        if (.NOT. allocated(weekyearf))     allocate(weekyearf(52,na))

        if (.NOT. allocated(tdistr))        allocate(tdistr(na))
        if (.NOT. allocated(asrc_tv))       allocate(asrc_tv(na))

        if (.NOT. allocated(vdistr))        allocate(vdistr(nz,na))

        if (.not. allocated(scale_sector))  allocate(scale_sector(na))
        if (.not. allocated(const_scaling)) allocate(const_scaling(nc,na))

! ***   Default setting:
        const_scaling = 1.0   ! NB: Should be applied in: "subroutine GetAsrcTimeDependentInputData"
        scale_sector  = 1.0   ! NB: Should be applied in: "subroutine GetAsrcTimeDependentInputData"
        vdistr        = 0.0   ! Zeroing the 2D vertical distribution array: "vdistr(nz,na)"

! ***   Initialize the time variation to: Non-varying with time, i.e.:
        tdistr = 1.0

! *************************************************************************************************

! ***   Start: TV-arrays default setting:

!MSK comment: only default time variation is used
        hourf(:,:,:)   = 1.0/24.0
        daywf(:,:)     = 1.0/7.0
        weekyearf(:,:) = 1.0/52.0

!MSK start
!MSK commented KPIZ simulation for more clarity
!
!        if (siteid(1:siteid_len) == 'KPIZ_Large_photochem' .OR. siteid(1:siteid_len) == 'KPIZ_Large_photoeq') then
!
!! ***     Start: TV-arrays for the "TRAFFIC" sector: **************************************************
!
!! ***     Houly (24 values) time variation "weekdays" = All but Friday  Traffic emissions:
!          hourf(:,1,na) = (/0.009, 0.005, 0.003, 0.004, 0.009, 0.029, 0.066, 0.055, 0.054, 0.059, &
!                       0.063, 0.060, 0.061, 0.058, 0.054, 0.051, 0.055, 0.060, 0.059, 0.058, &
!                       0.052, 0.039, 0.025, 0.012/)
!
!          test_variable    = SUM(hourf(1:23,1,na))
!!          hourf(24,1,na) = 1.0 - SUM(hourf(1:23,1,na))
!          hourf(24,1,na) = 1.0 - test_variable
!          do ih = 1,24
!            hourf(ih,1,na) = 24.0 * hourf(ih,1,na)
!          enddo
!
!! ***     Houly (24 values) time variation "Weekend"=Friday  Traffic emissions:
!          hourf(:,2,na) = (/0.013, 0.006, 0.005, 0.008, 0.010, 0.021, 0.028, 0.034, 0.041, 0.048, &
!                       0.051, 0.038, 0.039, 0.045, 0.051, 0.055, 0.071, 0.078, 0.075, 0.076, &
!                       0.073, 0.062, 0.045, 0.026/)
!
!          test_variable    = SUM(hourf(1:23,2,na))
!!          hourf(24,2,na) = 1.0 - SUM(hourf(1:23,2,na))
!          hourf(24,2,na) = 1.0 - test_variable
!          do ih = 1,24
!            hourf(ih,2,na) = 24.0 * hourf(ih,2,na)
!          enddo
!
!! ***     Daily (7 values) time variation    Monday - Sunday  Traffic emissions:
!          daywf(:,na) = (/0.155, 0.165, 0.150, 0.140, 0.110, 0.130, 0.150/)
!
!          test_variable = SUM(daywf(1:6,na))
!!          daywf(7,na) =  1.0 -  SUM(daywf(1:6,na))
!          daywf(7,na) =  1.0 -  test_variable
!          do iiday = 1,7
!            daywf(iiday,na) =  7.0 * daywf(iiday,na)
!          enddo
!
!! ***     Week number (52 values) time variation Traffic emissions:
!          weekyearf(:,na) = (/0.020, 0.021, 0.021, 0.020, 0.020, 0.020, 0.020, 0.020, 0.020, 0.020,  &
!                         0.020, 0.019, 0.019, 0.019, 0.019, 0.019, 0.019, 0.019, 0.019, 0.019, &
!                         0.019, 0.019, 0.019, 0.019, 0.019, 0.019, 0.019, 0.019, 0.019, 0.018, &
!                         0.017, 0.016, 0.016, 0.016, 0.017, 0.018, 0.019, 0.019, 0.019, 0.019, &
!                         0.019, 0.019, 0.019, 0.020, 0.020, 0.020, 0.020, 0.020, 0.020, 0.020, &
!                         0.020, 0.020/)
!
!          test_variable    = SUM(weekyearf(1:51,na))
!!          weekyearf(52,na) = 1.0 - SUM(weekyearf(1:51,na))
!          weekyearf(52,na) = 1.0 - test_variable
!          do iiweek = 1,52
!            weekyearf(iiweek,na) = 52.0 * weekyearf(iiweek,na)
!          enddo
!
!          do ia = 1,na
!            if(ia == 1) scale_sector(ia) = scale_residential ! Sector 1: "Residential"
!            if(ia == 2) scale_sector(ia) = scale_industry    ! Sector 2: "Industry"
!            if(ia == 3) scale_sector(ia) = scale_power       ! Sector 3: "Power"
!            if(ia == 4) scale_sector(ia) = scale_solvent     ! Sector 4: "Solvent"
!            if(ia == 5) scale_sector(ia) = scale_shipping    ! Sector 5: "Shipping"
!            if(ia == 6) scale_sector(ia) = scale_waste       ! Sector 6: "Waste"
!            if(ia == 7) scale_sector(ia) = scale_traffic     ! Sector 7: "Traffic"
!          enddo
!
!! ***     Specifying the sectors that applies TIME VARIATION in "CASRC":
!
!! ***     asrc_tv(1)      = .FALSE.  ! Sector 1: "Residential"
!! ***     asrc_tv(2)      = .FALSE.  ! Sector 2: "Industry"
!! ***     asrc_tv(3)      = .FALSE.  ! Sector 3: "Power"
!! ***     asrc_tv(4)      = .FALSE.  ! Sector 4: "Solvent"
!! ***     asrc_tv(5)      = .FALSE.  ! Sector 2: "Shipping"
!! ***     asrc_tv(6)      = .FALSE.  ! Sector 3: "Waste"
!! ***     asrc_tv(7=na)   = .TRUE.   ! Sector 7: "Traffic"
!
!          asrc_tv     = .false.
!          asrc_tv(na) = .true.
!
!! ***     Start: "KPIZ_Large_photochem" vertical distribution:
!          do ia = 1,na  ! Go through all the sectors:
!            if (ia == 1) then
!! ***         Sector 1: "Residential"
!              vdistr( 1,ia) = 0.60        !  60% in Layer  1: DZ(1)  = 17.5 m.
!              vdistr( 2,ia) = 0.40        !  40% in Layer  2: DZ(2)  = 20 m.
!            elseif (ia == 2) then
!! ***         Sector 2: "Industry"
!              vdistr( 2,ia) = 0.05        !   5% in Layer  2: DZ(2)  = 20 m.
!              vdistr( 3,ia) = 0.05        !   5% in Layer  3: DZ(3)  = 25 m.
!              vdistr( 4,ia) = 0.05        !   5% in Layer  4: DZ(4)  = 25 m.
!              vdistr( 5,ia) = 0.05        !   5% in Layer  5: DZ(5)  = 37.5 m.
!              vdistr( 6,ia) = 0.10        !  10% in Layer  6: DZ(6)  = 50 m.
!              vdistr( 7,ia) = 0.20        !  20% in Layer  7: DZ(7)  = 50 m.
!              vdistr( 8,ia) = 0.20        !  20% in Layer  8: DZ(8)  = 50 m.
!              vdistr( 9,ia) = 0.10        !  10% in Layer  9: DZ(9)  = 50 m.
!              vdistr(10,ia) = 0.10        !  10% in Layer 10: DZ(10) = 50 m.
!              vdistr(11,ia) = 0.05        !   5% in Layer 11: DZ(11) = 50 m.
!              vdistr(12,ia) = 0.05        !   5% in Layer 12: DZ(12) = 50 m.
!            elseif (ia == 3) then
!! ***         Sector 3: "Power"
!              vdistr( 6,ia) = 0.10        !  25% in Layer 10: DZ(6) = 50 m.
!              vdistr( 7,ia) = 0.15        !  50% in Layer 11: DZ(7) = 50 m.
!              vdistr( 8,ia) = 0.27        !  25% in Layer 12: DZ(8) = 50 m.
!              vdistr( 9,ia) = 0.35        !  50% in Layer 11: DZ(9) = 50 m.
!              vdistr(10,ia) = 0.13        !  13% in Layer 12: DZ(10) = 50 m.
!            elseif (ia == 4) then
!! ***         Sector 4: "Solvent"
!              vdistr( 1,ia) = 0.50        !  50% in Layer  1: DZ(1)  = 17.5 m.
!              vdistr( 2,ia) = 0.40        !  40% in Layer  2: DZ(2)  = 20 m.
!              vdistr( 3,ia) = 0.10        !  10% in Layer  3: DZ(3)  = 25 m.
!            elseif (ia == 5) then
!! ***         Sector 5: "Shipping"
!              vdistr( 1,ia) = 0.20        !  20% in Layer  1: DZ(1)  = 17.5 m.
!              vdistr( 2,ia) = 0.50        !  50% in Layer  2: DZ(2)  = 20 m.
!              vdistr( 3,ia) = 0.30        !  30% in Layer  3: DZ(3)  = 25 m.
!            elseif (ia == 6) then
!! ***         Sector 6: "Waste"
!              vdistr( 1,ia) = 1.0          ! 100% in Layer  1: DZ(1) = 17.5 m.
!            elseif (ia == 7) then
!! ***         Sector 7: "Traffic"
!              vdistr( 1,ia) = 1.0          ! 100% in Layer  1: DZ(1) = 17.5 m.
!            endif
!          enddo  !  do ia = 1,na
!
!MSK        elseif (siteid(1:siteid_len) == 'Rotterdam') then
!MSK end
          if (siteid(1:siteid_len) == 'Rotterdam') then

! ***     Specifying the sectors that applies TIME VARIATION in "CASRC":

! ***     asrc_tv(1)      = .FALSE.  ! Sector 1: "Other_than_Traffic"
! ***     asrc_tv(2)      = .FALSE.  ! Sector 2: "Traffic"

          asrc_tv       = .false.

! ***     Start: "Rotterdam" vertical distribution: (NOTE: At the moment equal to the "Default" setting below.)
          do ia = 1,na  ! Go through all the sectors:
            if (ia == 1) then
! ***         Sector 1: "Residential":
              vdistr(2, ia) = 1.0         !  100% in Layer  2: DZ(2)  = 20 m.
!_SEW_UncertWeb_120913_Start
              vdistr(2,ia) = DZ(2)/(DZ(2) + DZ(3) + DZ(4))
              vdistr(3,ia) = DZ(3)/(DZ(2) + DZ(3) + DZ(4))
              vdistr(4,ia) = DZ(4)/(DZ(2) + DZ(3) + DZ(4))
!SEW_UncertWeb_120913_End
            elseif (ia == 2) then
! ***         Sector 2: "Traffic":
              vdistr(1,ia) = 1.0          ! 100% in Layer  1: DZ(1) = 17.5 m.
            endif
          enddo ! do ia = 1,na

!MSK start
!MSK commented Bedre Byluft simulation for more clarity
!        elseif (siteid(1:7) == 'BB_UM20' .OR. siteid(1:7) == 'BB_HM20') then
!! ***     BEDRE BYLUFT Application:
!! ***     Specifying the sectors that applies TIME VARIATION in "CASRC":
!
!! ***     asrc_tv(1)      = .FALSE.  ! Sector 1: "Other_than_Traffic"
!! ***     asrc_tv(2)      = .FALSE.  ! Sector 2: "Traffic"
!
!          asrc_tv       = .false.
!
!! ***     Start: "Default" VERTICAL DISTRIBUTION:
!          do ia = 1,na  ! Go through all the sectors:
!            if (ia == 1) then
!! ***         Sector 1: "Residential":
!              if ((icmpnd(1) == 5 .AND. cmpnd(1)(1:3) == 'NO2') .OR. &
!             (icmpnd(1) == 7 .AND. cmpnd(1)(1:3) == 'NOx')) then
!! ***             NO2/NO/O3 simulation: "Residential" NO2 and NO emissions equally distributed
!! ***                                   in the two lowermost layers: 0 - 22 m.
!!                  vdistr(1,ia) = DZ(1)/(DZ(1)+DZ(2))  ! Layer 1:  0 - 5m.
!!                  vdistr(2,ia) = DZ(2)/(DZ(1)+DZ(2))  ! Layer 2:  5 - 22m.
!! ***                                   in layer 2 and 3: 5 - 45m.
!!                   vdistr(2,ia) = 1  ! Layer 2:  5 - 22m.
!                  vdistr(2,ia) = DZ(2)/(DZ(2)+DZ(3))  ! Layer 2:  5 - 22m.
!                  vdistr(3,ia) = DZ(3)/(DZ(2)+DZ(3))  ! Layer 3: 22 - 45m.
!              elseif((icmpnd(1) == 9  .AND. cmpnd(1)(1:4) == 'PM10') .OR.  &
!                (icmpnd(1) == 10 .AND. cmpnd(1)(1:5) == 'PM2.5')) then
!! ***                PM2.5 or PM10 simulation: "Residential" PM2.5 and PM10 emissions equally distributed
!! ***                                          in layer 2 and 3: 5 - 45 m.
!                  vdistr(2,ia) = 1  ! Layer 2:  5 - 22m.
!!                vdistr(2,ia) = DZ(2)/(DZ(2)+DZ(3))  ! Layer 2:  5 - 22m.
!!                vdistr(3,ia) = DZ(3)/(DZ(2)+DZ(3))  ! Layer 3: 22 - 45m.
!! ***                                          in layer 3 and 4:
!                ! vdistr(3,ia) = DZ(3)/(DZ(3)+DZ(4))  ! Layer 3: 22 - 45m.
!                ! vdistr(4,ia) = DZ(4)/(DZ(3)+DZ(4))  ! Layer 4: 45 - 75m.
!              else
!                if (messfe) then
!                  write(messun,*)
!                  write(messun,'(A)') 'CASRC: This is a BEDRE BYLUFT APPLCATION. '
!                 write(messun,'(A)') 'CASRC: Can only be run for NO2 (Test NOx), PM10 and PM2.5 '
!                 write(messun,'(A)') 'CASRC: PROGRAM TERMINATES! '
!                endif
!                STOP
!              endif
!            elseif (ia == 2) then
!! ***         Sector 2: "Traffic":
!              vdistr(1,ia) = 1.0          ! 100% in Layer 1
!            endif
!          enddo ! do ia = 1,na
!MSK end

          else    ! Default Distribution

! ***     Specifying the sectors that applies TIME VARIATION in "CASRC":

! ***     asrc_tv(1)      = .FALSE.  ! Sector 1: "Other_than_Traffic"
! ***     asrc_tv(2)      = .FALSE.  ! Sector 2: "Traffic"

          asrc_tv       = .false.

! ***     Start: "Default" VERTICAL DISTRIBUTION: BRUCE changed this not quite finished zdistr_min only works when equivalent to a layer height
          do ia = 1,na  ! Go through all the sectors:
            if (ia == 1) then
! ***         Sector 1: "Upper": BRUCE   (domestic heating)
                zdistr_max=max(35.0,Z(1))

                zdistr_min=Z(1)

!MSK start: this was used for pnc. Layer 1 has 0%
!MSK                do iz=1,nz-1
!MSK                  if (Z(iz).le.zdistr_max.and.Z(iz).gt.zdistr_min) then
!MSK                    vdistr(iz,ia) = DZ(iz)/(zdistr_max-zdistr_min)
!MSK                  elseif (Z(iz).gt.zdistr_max.and.Z(iz).gt.zdistr_min) then
!MSK                    vdistr(iz,ia) = max(dble(0.0),(zdistr_max-Z(iz)+DZ(iz)))/(zdistr_max-zdistr_min)
!MSK                  else
!MSK                    vdistr(iz,ia) = 0
!MSK                  endif
!MSK                enddo
!MSK end
!MSK start
!MSK for now put all in first layer to get max impact
!!!              vdistr(1,ia) = 1.0          ! 100% in Layer 1
!MSK              vdistr(1,ia) = 0.7          ! 70% in Layer 1
!MSK              vdistr(2,ia) = 0.3          ! 30% in Layer 2
              vdistr(1,ia) = 0.9          ! 90% in Layer 1
              vdistr(2,ia) = 0.1          ! 10% in Layer 2
!MSK end
            elseif (ia == 2) then
! ***         Sector 2: "Traffic":
!MSK: sector not used, because all traffic is line source
              vdistr(1,ia) = 1.0          ! 100% in Layer 1

            elseif (ia == 3) then
! ***         Sector 3: "Other"   "lower":BRUCE
!!!             vdistr(1,ia) = 1.0          ! 100% in Layer 1
!MSK start
!MSK              vdistr(1,ia) = 0.7          ! 70% in Layer 1
!MSK              vdistr(2,ia) = 0.3          ! 30% in Layer 2
              vdistr(1,ia) = 0.8          ! 80% in Layer 1
              vdistr(2,ia) = 0.2          ! 20% in Layer 2
            elseif (ia == 4) then
! ***         Sector 4: "Shipping"
! ***              Default "50/50": (100% below 37.5m)
!              vdistr(1,ia) = 0.5          ! 50% in Layer 1
!              vdistr(2,ia) = 0.5          ! 50% in Layer 2
! ***              TEST CMAQ-distribution
              vdistr(1,ia) = 0.25         ! 25% in Layer 1
              vdistr(2,ia) = 0.25         ! 25% in Layer 2
              vdistr(3,ia) = 0.25         ! 25% in Layer 1
              vdistr(4,ia) = 0.25         ! 25% in Layer 2
            endif
!MSK end

          enddo ! do ia = 1,na

        endif

! ***   Write out the applied vertical distribution at the start of the simulation:
        if (messfe) then
          write(messun,*)
          write(messun,'(A)') 'CASRC: The following vertical distribution of area sources is now applied: '
          write(messun,'(A)') 'CASRC: (NB: All other "vdistr(iz,ia)" values are equal to zero. '
          write(messun,*)
          do iz = 1,nz
            do ia = 1,na
              if (vdistr(iz,ia) /= 0.) then
                write(messun,'(A,F8.4,2(A,I3))')  &
                'CASRC: "vdistr(iz,ia)" = ',vdistr(iz,ia),' for "iz" = ',iz,' and "ia" = ',ia
              endif
            enddo
          enddo

          write(messun,*)
          do ia = 1,na
            write(messun,'(A,F8.4,A,I3)')   'CASRC: "scale_sector(ia)"    = ',scale_sector(ia),' for "ia" = ',ia
          enddo
          write(messun,*)

        endif  ! if (messfe)

      endif  ! if (ATTIME(BDAT) .AND. ISH == 1 .AND. ITS == 1 .AND. messfe) then

! *** End defining the Vertical Distribution of the Asrc Emissions. Done at start of simulation.
! ****************************************************************************************************************

! *** START TIME VARIATION Initialisation and update of the week-number:

!MSK start
!MSK commented KPIZ simulation for more clarity
!! *** Start: "KPIZ_Large_photochem" application SPECIFIC CODE for September 2010:
!      if (siteid(1:siteid_len) == 'KPIZ_Large_photochem' .OR. siteid(1:siteid_len) == 'KPIZ_Large_photoeq') then
!
!! ***   HARD-CODING:
!        if (dayy == 244) then
!          iweeknr = 35      ! The start value.
!          if (messfe) then
!            write(messun,'(A,I5)') 'CASRC: Week number start at: ',iweeknr
!          endif
!        endif  ! if (dayy == 244)
!        if (hour == 0 .AND. dayw == 1) then
!          iweeknr = iweeknr + 1
!          if (messfe) then
!            write(messun,'(A,I5)') 'CASRC: Week number increased to: ',iweeknr
!          endif
!        endif  ! if (hour == 0 .AND. dayw == 1)
!
!        if (dayw == 4) then    ! Friday (= weekend in Abu Dhabi).
!          if (messfe) then
!            write(messun,'(A,I5)') 'CASRC: dayw is now equal to ',dayw
!          endif
!        endif  ! if (dayw == 4)
!
!      endif  ! if (siteid(1:siteid_len) == 'KPIZ_Large_photochem' .OR. siteid(1:siteid_len) == 'KPIZ_Large_photoeq')

! *** END TIME VARIATION Initialisation and update of the week-number.

! *** Presently the "KPIZ_Large_photochem" or "KPIZ_Large_photoeq" applications for September 2010
! *** only apply time variations for the "Traffic" sector, i.e. ia = 7.
!MSK comment: in the Default Application the default (=uniform equal) time factors are applied

!MSK start 26.09.2017 QA zero emission value before emission adding:
      qa(:,:,:,:) = 0.0

      do ia = 1,na

!MSK start 26.09.2017
!MSK        if (messfe .and. asrc_tv(ia) ) then
!MSK          write(messun,'(A,I4)') 'CASRC: asrc_tv(ia) = .true. for ia = ',ia
!MSK        endif
!MSK
!MSK ! ***   Only apply variable time variation for the selected sectors:
!MSK        if (asrc_tv(ia)) then
!MSK
!MSK ! ***     Find if "weekend", i.e. in this case just Friday:
!MSK          if (dayw == 5) then
!MSK            tdistr(ia) = hourf(hour+1,2,ia) * daywf(dayw,ia) * weekyearf(iweeknr,ia)
!MSK          else
!MSK            tdistr(ia) = hourf(hour+1,1,ia) * daywf(dayw,ia) * weekyearf(iweeknr,ia)
!MSK          endif
!MSK        else

! ***     Now no timevariation should be applied, and "tdistr(ia)" should now be identical equal to 1.0
          tdistr(ia) = 1.0
!MSK
!MSK        endif  ! if (asrc_tv(ia) == .false.)
!MSK end 26.09.2017

        if (messfe) then
          write(messun,'(A,F8.4,A,I3)')   'CASRC: "tdistr(ia)"    = ',tdistr(ia),' for "ia" = ',ia
        endif

! ***   Calculate the GRID DISTRIBUTED EMISSIONS:

! ***   Go through all the species:
        do ic = 1,nc
! ***     Apply the time-variation on the "2D" qaorig-array for Sector "ia":
          do ix = 1,nx
            do iy = 1,ny

!MSK start 26.09.2017
!MSK               if (ix >= ix_select_min .AND. ix <= ix_select_max .AND. &
!MSK              iy >= iy_select_min .AND. iy <= iy_select_max) then
!MSK                  const_scaling(ic,ia) = scale_sector(ia)  ! Scale each sector separately
!MSK               else
!MSK                  const_scaling(ic,ia) = 1.0
!MSK               endif
!MSK end 26.09.2017

!_WITH NO TIMEVARIATION:              tv_qaorig = qaorig(ic,ix,iy,ia)
!MSK: The standard is that emissions already have their time variation
!MSK: so tdistr(ia) = 1.0 and const_scaling(ic,ia) = 1.0
!MSK start
                const_scaling(ic,ia) = 1.0
!MSK end
                tv_qaorig = qaorig(ic,ix,iy,ia) * tdistr(ia) * const_scaling(ic,ia)

! ***         Then apply the vertical distribution for this Sector:
              do iz = 1,nz    ! Here we could limit ourself to: iz = 1,12
                 qa(ic,ix,iy,iz) = qa(ic,ix,iy,iz) + ( vdistr(iz,ia) * tv_qaorig)
              enddo  ! do iz = 1,nz
            enddo  ! do iy = 1,ny
          enddo  !  do ix = 1,nx
        enddo  ! do ic = 1,nc

      enddo  ! do ia = 1,na

! Check ship emissions of NO
!     do ix = 15,15
!        do iy = 1,ny
!          do iz = 1,6
!            print *,'casrc ship-NO qa',ix,iy, qa(2,ix,iy,1)
!                    , vdistr(iz,1),  &
!                    qaorig(3,ix,iy,1),qaorig(3,ix,iy,2),qaorig(3,ix,iy,3),qaorig(3,ix,iy,4)
!          enddo
!        enddo
!     enddo

      if (messfe) then
        write(messun,*)
        write(messun,'(A)') 'CASRC: Have now included all ASRC emissions in units of "g/s":'
          rmax_qa     = MAXVAL(qa(2,:,:,:))
        write(messun,'(42X,3A4)') '  I ','  J ','  K '
        write(messun,'(A,E12.5,A,3I4)') &
          'CASRC-1: Max QA(IC=2, NO): ',rmax_qa,' g/s. ',MAXLOC(qa(2,:,:,:))
        write(messun,*)
        if(nc == 3) then
            rmax_qa     = MAXVAL(qa(2,:,:,:))
          write(messun,'(42X,3A4)') '  I ','  J ','  K '
          write(messun,'(A,E12.5,A,3I4)') &
            'CASRC-1: Max QA(IC=2): ',rmax_qa,' g/s. ',MAXLOC(qa(2,:,:,:))
          write(messun,*)
           rmax_qa     = MAXVAL(qa(3,:,:,:))
          write(messun,'(42X,3A4)') '  I ','  J ','  K '
          write(messun,'(A,E12.5,A,3I4)') &
            'CASRC-1: Max QA(IC=3): ',rmax_qa,' g/s. ',MAXLOC(qa(3,:,:,:))
          write(messun,*)
        endif
      endif

! *** Add Point Source emissions to Grid:
      if (psrcmtype < 1) then
        CALL PSRCtoASRC

        if (messfe) then
          write(messun,*)
          write(messun,'(A)') 'CASRC: Have now added the PSRC Emissions to the Area Sources:'
          rmax_QA     = MAXVAL(qa(1,:,:,:))
          write(messun,'(42X,3A4)') '  I ','  J ','  K '
          write(messun,'(A,E12.5,A,3I4)') &
          'CASRC-2: Max QA(IC=1): ',rmax_qa,' g/s. ',MAXLOC(qa(1,:,:,:))
          write(messun,*)
          if(nc == 3)then
            rmax_QA     = MAXVAL(qa(2,:,:,:))
            write(messun,'(42X,3A4)') '  I ','  J ','  K '
            write(messun,'(A,E12.5,A,3I4)') &
            'CASRC-2: Max QA(IC=2): ',rmax_qa,' g/s. ',MAXLOC(qa(2,:,:,:))
            write(messun,*)
            rmax_QA     = MAXVAL(qa(3,:,:,:))
            write(messun,'(42X,3A4)') '  I ','  J ','  K '
            write(messun,'(A,E12.5,A,3I4)') &
            'CASRC-2: Max QA(IC=3): ',rmax_qa,' g/s. ',MAXLOC(qa(3,:,:,:))
            write(messun,*)
          endif
        endif  ! if (messfe)

      endif  ! if (psrcmtype < 1)

      if ((siteid(1:siteid_len) == 'KPIZ_Large_photochem' .OR. siteid(1:siteid_len) == 'KPIZ_Large_photoeq')  &
     .AND. messfe) then
        avg_hour_wd_tv = (SUM(hourf(:,1,na)))/24.0
        avg_hour_we_tv = (SUM(hourf(:,2,na)))/24.0
        avg_day_tv     = (SUM(daywf(:,na)))/7.0
        avg_week_tv    = (SUM(weekyearf(:,na)))/52.0
        write(messun,*)
        write(messun,'(A,F8.4,A,I3)') 'CASRC: avg_hour_wd_tv  = ',avg_hour_wd_tv,' for Sector: ',na
        write(messun,'(A,F8.4,A,I3)') 'CASRC: avg_hour_we_tv  = ',avg_hour_we_tv,' for Sector: ',na
        write(messun,'(A,F8.4,A,I3)') 'CASRC: avg_day_tv      = ',avg_day_tv,' for Sector: ',na
        write(messun,'(A,F8.4,A,I3)') 'CASRC: avg_week_tv     = ',avg_week_tv,' for Sector: ',na
      endif

      RETURN

!     End of subroutine CASRC

      end subroutine casrc


*
*     -------------------------------------------------------------
*      B L O C K   D A T A   R I B L S
*     -------------------------------------------------------------
*
*     Written by G. Gaigalas,                                      *
*     Vanderbilt University,  Nashville             October 1996   *
*
      BLOCK DATA RIBLS
      COMMON/RIBOLS/IMPTLS(40),IMGTLS(40),IMPNLS(40),IMGNLS(40)
      COMMON/RIBOLSF/IMPTLSF(8),IMGTLSF(8),IMPNLSF(8),IMGNLSF(8)
      COMMON/RIBOF/IMPTF(238),IMGTF(238),IMPNF(238),IMGNF(238)
      COMMON/RIBOLS3/IMPTLS3(90),IMGTLS3(90),IMPNLS3(90),IMGNLS3(90)
      DATA IMPTLS/1,2,3*3,3*6,16*9,16*25/
      DATA IMGTLS/1,2,3*5,3*8,16*24,16*40/
      DATA IMPNLS/2,1,3*6,3*3,16*25,16*9/
      DATA IMGNLS/2,1,3*8,3*5,16*40,16*24/
      DATA IMPTLSF/301,7*302/
      DATA IMGTLSF/301,7*308/
      DATA IMPNLSF/302,7*301/
      DATA IMGNLSF/308,7*301/
      DATA IMPTF/119*1,119*120/
      DATA IMGTF/119*119,119*238/
      DATA IMPNF/119*120,119*1/
      DATA IMGNF/119*238,119*119/
      DATA IMPTLS3/1,9*2,11,11*12,23,13*24,37,15*38,53,17*54,71,
     *19*72/
      DATA IMGTLS3/1,9*10,11,11*22,23,13*36,37,15*52,53,17*70,71,
     *19*90/
      DATA IMPNLS3/2,9*1,12,11*11,24,13*23,38,15*37,54,17*53,72,
     *19*71/
      DATA IMGNLS3/10,9*1,22,11*11,36,13*23,52,15*37,70,17*53,90,
     *19*71/
      END


character*2 itinv
character*8 ar,md,line
character*1 it,itold,ppss,rm,gr

real matruzel(3000)
integer muzel(3000),ist_p(5000),ist_s(5000)

real dv_zn_p(3),dv_zn_s(3)

real ylev_p(200),ylev_s(200)
integer nt_p(200),npz_p(10),nt_s(200),npz_s(10),nrps(2)

allocatable  xtop_p(:,:), ztop_p(:,:)
allocatable  xtop_s(:,:), ztop_s(:,:)
allocatable kpop_p(:,:),kobr_p(:,:),kpz_p(:)
allocatable kpop_s(:,:),kobr_s(:,:),kpz_s(:)

allocatable dvp_it(:),dvs_it(:),dt_it(:)
allocatable x_ztr(:),y_ztr(:),z_ztr(:),t_ztr(:),p_sta(:),s_sta(:)

allocatable x(:),x0(:),u(:),v(:),w(:),aaa(:),dt(:),xmod(:)
allocatable ncolrow(:),ncol(:)

common/velmod/nnps,ypros,xpros,zpros,cfps
common/inipar/nzone,nsurf,smth,xlim1,xlim2,ylim1,ylim2,zlim1,zlim2
common/itstep/itstep

pi=3.1415926
iter_max=1
it_curr=1
w_act=1

open(1,file='../../../model.dat')
read(1,'(a8)')ar		! code of the area
read(1,'(a8)')md		! code of the area
read(1,*)iter		! code of the grid
read(1,*)igr		! code of the grid
close(1)
write(gr,'(i1)')igr
write(it,'(i1)')iter
write(itold,'(i1)')iter-1

write(*,*)' execution of invers'
write(*,*)' ar=',ar,' md=',md,' it=',it,' gr=',gr

!******************************************************************
key_ft1_xy2=1
key_true1=0
key_flat1=1
open(1,file='../../../DATA/'//ar//'/'//md//'/MAJOR_PARAM.DAT')
do i=1,10000
    read(1,'(a8)',end=513)line
    if(line.eq.'GENERAL ') goto 514
end do
513 continue
write(*,*)' cannot find GENERAL INFORMATION in MAJOR_PARAM.DAT!!!'
pause
514 continue
read(1,*)
read(1,*)
read(1,*)
read(1,*)
read(1,*,end=441,err=441)key_ft1_xy2
read(1,*,end=441,err=441)key_true1
read(1,*,end=441,err=441)key_flat1      ! 1: calculations in flat model, 2: spherical velocity
441 close(1)

!******************************************************************
open(1,file='../../../DATA/'//ar//'/'//md//'/MAJOR_PARAM.DAT')
do i=1,10000
	read(1,'(a8)',end=573)line
	if(line.eq.'INVERSIO') goto 574
end do
573 continue
write(*,*)' cannot find INVERSION PARAMETERS in MAJOR_PARAM.DAT!!!'
pause
574 continue
read(1,*)iter_lsqr
read(1,*)wg_vel_p,wg_vel_s
read(1,*)sm_hor_p,sm_hor_s
read(1,*)sm_ver_p,sm_ver_s
read(1,*)rg_amp_p,rg_amp_s
read(1,*)
read(1,*)wg_st_p,wg_st_s
read(1,*)wzt_hor
read(1,*)wzt_ver
read(1,*)wzt_time
close(1)
!******************************************************************

call read_vref(ar,md)
call read_3D_mod_v(ar,md,iter-1)
call read_ini_model(ar,md)

open(1,file='../../../DATA/'//ar//'/'//md//'/data/numray1.dat')
read(1,*) nrps(1),nrps(2)
close(1)

open(1,file='../../../DATA/'//ar//'/'//md//'/data/numbers'//it//gr//'.dat')
read(1,*)nray,nobr_p,nobr_s,nztr,nonzer
read(1,*)nrp,nonz_p
read(1,*)nrs,nonz_s
close(1)

write(*,*)' Number of events =',nztr

allocate (x_ztr(nztr),y_ztr(nztr),z_ztr(nztr),t_ztr(nztr))
x_ztr=0
y_ztr=0
z_ztr=0
t_ztr=0

! Read the coordinates of the stations
open(2,file='../../../DATA/'//ar//'/'//md//'/data/stat_xy.dat')
i=0
3	i=i+1
	read(2,*,end=4)xstn,ystn,zstn
	goto 3
4	close(2)
nstat=i-1
write(*,*)' Number of stations=',nstat

allocate (p_sta(nstat),s_sta(nstat))

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

if(nrps(1).ne.0) then
	open(1,file='../../../DATA/'//ar//'/'//md//'/data/obr1'//gr//'.dat')
	read(1,*) nvel_p
	allocate(dvp_it(nvel_p),kpz_p(nvel_p),kobr_p(nvel_p,2))
	read(1,*)((kobr_p(i,j),i=1,nvel_p), j=1,2)
	close(1)
end if

if(nrps(2).ne.0) then
	open(1,file='../../../DATA/'//ar//'/'//md//'/data/obr2'//gr//'.dat')
	read(1,*) nvel_s
	allocate(dvs_it(nvel_s),kpz_s(nvel_s),kobr_s(nvel_s,2))
	read(1,*)((kobr_s(i,j),i=1,nvel_s), j=1,2)
	close(1)
end if
write(*,*)' nvel_p=',nvel_p,' nvel_s=',nvel_s

dvp_it=0
dvs_it=0

open(1,file='../../../DATA/'//ar//'/'//md//'/data/kall_xy1'//gr//'.dat')
read(1,*)nxpl,nypl
close(1)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

if(nrps(1).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/gr1'//gr//'.dat')
    nmax=0
    do n=1,nypl
        read(1,*)nt,ylev_p(iy)
        if(nt.gt.nmax) nmax=nt
        do i=1,nt
            read(1,*)x,z,l
        end do
    end do
    close(1)
    !write(*,*)' nmax=',nmax

    allocate(xtop_p(nmax,nypl),ztop_p(nmax,nypl),kpop_p(nmax,nypl))

    open(1,file='../../../DATA/'//ar//'/'//md//'/data/gr1'//gr//'.dat')
    npz_p=0
    do n=1,nypl
        read(1,*)nt
        !write(*,*)n,' ntop=',nt
        nt_p(n)=nt
        do i=1,nt_p(n)
            read(1,*)xtop_p(i,n),ztop_p(i,n),kpop_p(i,n)
        end do
    end do
    close(1)
end if

if(nrps(2).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/gr2'//gr//'.dat')
    nmax=0
    do n=1,nypl
        read(1,*)nt
        if(nt.gt.nmax) nmax=nt
        do i=1,nt
            read(1,*)x,z,l
        end do
    end do
    close(1)
    !write(*,*)' nmax=',nmax

    allocate(xtop_s(nmax,nypl),ztop_s(nmax,nypl),kpop_s(nmax,nypl))

    open(1,file='../../../DATA/'//ar//'/'//md//'/data/gr2'//gr//'.dat')
    do n=1,nypl
        read(1,*)nt
        nt_s(n)=nt
        do i=1,nt_s(n)
            read(1,*)xtop_s(i,n),ztop_s(i,n),kpop_s(i,n)
        end do
    end do
    close(1)
end if

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

nonz=0
ir=0
avdt=0
totmat=0
nst_p=0
nst_p=0

open(3,file='../../../TMP_files/tmp/matr'//it//gr//'.dat',form='binary')

95  read(3,end=96) nuz,resid,ist,ips,izt
    !write(*,*) nuz,resid,ist,ips,izt
    read(3)dtdx,dtdy,dtdz
    if(nuz.ne.0)read(3) (muzel(ii),matruzel(ii),ii=1,nuz)

    ir=ir+1
    nonz = nonz + nuz
    if(ist.eq.0) goto 95

    nonz = nonz + 5

    if(ips.eq.1)then
        if(nst_p.ne.0) then
            do i=1,nst_p
	            if(ist_p(i).eq.ist) goto 298
            end do
        end if
        nst_p=nst_p+1
        ist_p(nst_p)=ist
    else
        if(nst_s.ne.0) then
            do i=1,nst_s
	            if(ist_s(i).eq.ist) goto 298
            end do
        end if
        nst_s = nst_s + 1
        ist_s(nst_s) = ist
    end if

    298	continue
    !if(ir.eq.35375)write(*,*)' ir=',ir,' nonz=',nonz

    goto 95
96  close(3)

write(*,*)' Main matrix: nonz=',nonz,' ir=',ir

allocate (dt_it(ir))
write(*,*)' Number of rays =',nray,ir,' nzt=',nztr
write(*,*)' nst_p=',nst_p,' nst_s=',nst_s

dt_it=0
p_sta=0
s_sta=0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

nc = nvel_p + nvel_s + nst_p + nst_s + nztr*4

nonzer=nonz
!write(*,*)nvel_p,nvel_s,nst_p,nst_s,nztr
!write(*,*)' number of columns: =',nc

np1=nvel_p
np2=np1+nvel_s
np3=np2+nst_p
np4=np3+nst_s
!write(*,*)' np1=',np1,' np2=',np2,' np3=',np3

nrows=nray

if(nrps(1).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_hor1'//gr//'.dat',form='binary')
    read(1)link_hor_p
    write(*,*)' link_hor_p=',link_hor_p
    close(1)
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_ver1'//gr//'.dat',form='binary')
    read(1)link_ver_p
    write(*,*)' link_ver_p=',link_ver_p
    close(1)
end if

if(nrps(2).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_hor2'//gr//'.dat',form='binary')
    read(1)link_hor_s
    write(*,*)' link_hor_s=',link_hor_s
    close(1)
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_ver2'//gr//'.dat',form='binary')
    read(1)link_ver_s
    write(*,*)' link_ver_s=',link_ver_s
    close(1)
end if

if(sm_hor_p.gt.0.0001.and.nrps(1).ne.0) then
	nonzer = nonzer + link_hor_p*2
	nrows = nrows + link_hor_p
end if
if(sm_ver_p.gt.0.0001.and.nrps(1).ne.0) then
	nonzer = nonzer + link_ver_p*2
	nrows = nrows + link_ver_p
end if
if(sm_hor_s.gt.0.0001.and.nrps(2).ne.0) then
	nonzer = nonzer + link_hor_s*2
	nrows = nrows + link_hor_s
end if
if(sm_ver_s.gt.0.0001.and.nrps(2).ne.0) then
	nonzer = nonzer + link_ver_s*2
	nrows = nrows + link_ver_s
end if
write(*,*)' After Smoothing : ir=',nrows,' nonz=',nonzer

if(rg_amp_p.gt.0.0001.and.nrps(1).ne.0) then
	nonzer=nonzer+nvel_p
	nrows=nrows+nvel_p
end if
if(rg_amp_s.gt.0.0001.and.nrps(2).ne.0) then
	nonzer=nonzer+nvel_s
	nrows=nrows+nvel_s
end if

write(*,*)' nvel_p=',nvel_p,' nvel_s=',nvel_s
write(*,*)' Preliminary values: N rows=',nrows,' N nonzer=',nonzer
write(*,*)

allocate(xmod(nc),x(nc),x0(nc),v(nc),w(nc))
allocate(ncol(nrows),dt(nrows),u(nrows))
allocate(aaa(nonzer),ncolrow(nonzer))

nonz=0

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ir0=0
ir=0
amatsum=0
open(3,file='../../../TMP_files/tmp/matr'//it//gr//'.dat',form='binary')
    97	read(3,end=98) nuz,resid,ist,ips,izt
    read(3)dtdx,dtdy,dtdz
    ir0=ir0+1
    if(nuz.ne.0)read(3) (muzel(ii),matruzel(ii),ii=1,nuz)
    ir=ir+1

!    if(ir.eq.24310) then
!        write(*,*)' nuz=',nuz,' resid=',resid
!        write(*,*)' ist=',ist,' ips=',ips,' izt=',izt
!        write(*,*)' dtdx=',dtdx,' dtdy=',dtdy,' dtdz=',dtdz
!        do ii=1,nuz
!            write(*,*)muzel(ii),matruzel(ii)
!        end do
!        stop
!    end if

    dt(ir) = resid
    do ii=1,nuz
        mmm=muzel(ii)
        nnp=0
        if(ips.eq.2) nnp=np1
        add = wg_vel_p
        if(ips.eq.2) add = wg_vel_s
        nonz=nonz+1
        aaa(nonz) = matruzel(ii) * add
        ncolrow(nonz)=nnp+mmm
    end do
    !write(*,*)' dt=',dt(ir)

    ncol(ir) = nuz

    if(ist.eq.0) goto 97

    ncol(ir) = ncol(ir) + 4 + 1

    if(ips.eq.1) then
        do i=1,nst_p
            if(ist_p(i).ne.ist) cycle
            nonz=nonz+1
            aaa(nonz)=wg_st_p
            ncolrow(nonz)=np2+i
            exit
        end do
    else
        do i=1,nst_s
            if(ist_s(i).ne.ist) cycle
            nonz=nonz+1
            if(nonz.ge.nonzer) pause'7'
            aaa(nonz)=wg_st_s
            ncolrow(nonz)=np3+i
            exit
        end do
    end if

    nonz=nonz+1
    aaa(nonz)=dtdx*wzt_hor
    ncolrow(nonz)=np4 + (izt-1)*4 + 1
    !write(*,*)' ztr:',nonz,ncolrow(nonz),aaa(nonz)
    nonz=nonz+1
    aaa(nonz)=dtdy*wzt_hor
    ncolrow(nonz)=np4 + (izt-1)*4 + 2
    !write(*,*)' ztr:',nonz,ncolrow(nonz),aaa(nonz)
    nonz=nonz+1
    aaa(nonz)=dtdz*wzt_ver
    ncolrow(nonz)=np4 + (izt-1)*4 + 3
    !write(*,*)' ztr:',nonz,ncolrow(nonz),aaa(nonz)
    nonz=nonz+1
    aaa(nonz)=wzt_time
    ncolrow(nonz)=np4 + (izt-1)*4 + 4
    !write(*,*)' ztr:',nonz,ncolrow(nonz),aaa(nonz)
    !pause

    goto 97
98    continue
close(3)
write(*,*)' Main matrix: nonz=',nonz,' ir=',ir

if(sm_hor_p.gt.0.0001.and.nrps(1).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_hor1'//gr//'.dat',form='binary')
    read(1)link_hor_p
    do ilink=1,link_hor_p
        read(1)ipar1,ipar2
        ir=ir+1
        dt(ir)=0.
        ncol(ir)=2
        smth=sm_hor_p
        nonz=nonz+1
        aaa(nonz)=smth; ncolrow(nonz) = ipar1
        nonz=nonz+1
        aaa(nonz)=-smth; ncolrow(nonz) = ipar2
    end do
    close(1)
end if
if(sm_ver_p.gt.0.0001.and.nrps(1).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_ver1'//gr//'.dat',form='binary')
    read(1)link_ver_p
    do ilink=1,link_ver_p
        read(1)ipar1,ipar2
        ir=ir+1
        dt(ir)=0.
        ncol(ir)=2
        smth=sm_ver_p
        nonz=nonz+1
        aaa(nonz)=smth; ncolrow(nonz) = ipar1
        nonz=nonz+1
        aaa(nonz)=-smth; ncolrow(nonz) = ipar2
    end do
    close(1)
end if
if(sm_hor_s.gt.0.0001.and.nrps(2).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_hor2'//gr//'.dat',form='binary')
    read(1)link_hor_s
    do ilink=1,link_hor_s
        read(1)ipar1,ipar2
        ir=ir+1
        dt(ir)=0.
        ncol(ir)=2
        smth=sm_hor_s
        nonz=nonz+1
        aaa(nonz)=smth; ncolrow(nonz) = np1 + ipar1
        nonz=nonz+1
        aaa(nonz)=-smth; ncolrow(nonz) = np1 + ipar2
    end do
    close(1)
end if
if(sm_ver_s.gt.0.0001.and.nrps(2).ne.0) then
    open(1,file='../../../DATA/'//ar//'/'//md//'/data/link_ver2'//gr//'.dat',form='binary')
    read(1)link_ver_s
    do ilink=1,link_ver_s
        read(1)ipar1,ipar2
        ir=ir+1
        dt(ir)=0.
        ncol(ir)=2
        smth=sm_ver_s
        nonz=nonz+1
        aaa(nonz)=smth; ncolrow(nonz) = np1 + ipar1
        nonz=nonz+1
        aaa(nonz)=-smth; ncolrow(nonz) = np1 + ipar2
    end do
    close(1)
end if

write(*,*)' After Smoothing : ir=',ir,' nonz=',nonz

if(rg_amp_p.gt.0.0001.and.nrps(1).ne.0) then
    do i=1,nvel_p
        ir=ir+1
        dt(ir)=0.
        ncol(ir)=1
        nonz=nonz+1
        aaa(nonz)=rg_amp_p
        ncolrow(nonz)= i
    end do
end if

if(rg_amp_s.gt.0.0001.and.nrps(2).ne.0) then
    do i=1,nvel_s
        ir=ir+1
        dt(ir)=0.
        ncol(ir)=1
        nonz=nonz+1
        aaa(nonz)=rg_amp_s
        ncolrow(nonz)= np1 + i
    end do
end if

write(*,*)' After Regularization: ir=',ir,' nonz=',nonz

nz=nonz
nr=ir

do i=1,nr
	u(i)=dt(i)
end do

kount=0
amatsum=0
do irw=1,nr
    do ii=1,ncol(irw)
        kount=kount+1
        nn=ncolrow(kount)
        !write(*,*)' nn=',nn,' aaa=',aaa(kount)
        if(abs(u(irw)).gt.1.e10) then
            write(*,*)' Warning!!!'
            write(*,*)' dt=',u(irw)
            pause
        end if
        amatsum=amatsum+aaa(kount)
        if(abs(aaa(kount)).gt.1.e10) then
            write(*,*)' Warning!!!'
            write(*,*)' irw=',irw,' kount=',kount,' nn=',nn
            write(*,*)' aaa=',aaa(kount)
            stop
        end if
        if(nn.le.0.or.nn.gt.nc) then
            write(*,*)' Warning!!!'
            write(*,*)' irw=',irw,' nn=',nn
            pause
        end if
    end do
    !if(irw.ge.31400.and.irw.le.31500) write(*,*)' irw=',irw,' dt=',u(irw),amatsum
end do
write(*,*)' N rows=',nr,' N columns=',nc,' N nonzer=',nz
write(*,*)

!*******************************************************
!*******************************************************
!*******************************************************
call pstomo(nr,nc,x,u,v,w,iter_lsqr,nz,aaa,ncolrow,ncol)
!*******************************************************
!*******************************************************
!*******************************************************
err=0
kount=0
avres=0.
avres0=0.
dtvel=0
dtsta=0
dtztr=0
write(*,*)' nray=',nray
do irw=1,nray
	dt1=0
	do ii=1,ncol(irw)
		kount=kount+1
		nn=ncolrow(kount)
		dt1=dt1+aaa(kount)*x(nn)
	end do
	if(irw.le.nray)dt_it(irw)=dt_it(irw)+dt1
	avres=avres+abs(dt(irw)-dt1)
	avres0=avres0+abs(dt(irw))
end do
avres=avres/nray
avres0=avres0/nray
reduct=((avres0-avres)/avres0)*100.

write(*,*)'_____________________________________________________________'
write(*,*)' avres0=',avres0,' avres=',avres,' red=',reduct
write(*,*)'_____________________________________________________________'

if(nrps(1).ne.0) then
	avdvp=0
	open(11,file='../../../DATA/'//ar//'/'//md//'/data/vel_p_'//it//gr//'.dat')
	if(iter.gt.1) open(1,file='../../../DATA/'//ar//'/'//md//'/data/vel_p_'//itold//gr//'.dat')
	do i=1,nvel_p

		if(iter.gt.1) then
			read(1,*)dvp_old,vvp
		else
			dvp_old=0
			i1=kobr_p(i,1)
			i2=kobr_p(i,2)
			!write(*,*)' i1=',i1,' i2=',i2
			if(i1.eq.0) cycle
			xx=xtop_p(i1,i2)
			yy=ylev_p(i2)
			zz=ztop_p(i1,i2)

			vvp=velocity(xx,yy,zz,1)
			!write(*,*)' xx=',xx,' yy=',yy,' zz=',zz
			!write(*,*)' vvp=',vvp
		end if

		dvp = x(i) * wg_vel_p

		dvp_it(i) = dvp_it(i) + dvp

		dvp_new = dvp_old + dvp_it(i)

		write(11,*)dvp_new,vvp

		avdvp=avdvp+100*abs(dvp)/vvp
	end do
	close(11)
	if(iter.gt.1) close(1)
	avdvp=avdvp/nvel_p
end if

!write(*,*)' nrps=',nrps(1),nrps(2)

if(nrps(2).ne.0) then
	avdvs=0
	open(11,file='../../../DATA/'//ar//'/'//md//'/data/vel_s_'//it//gr//'.dat')
	if(iter.gt.1) open(1,file='../../../DATA/'//ar//'/'//md//'/data/vel_s_'//itold//gr//'.dat')
	do i=1,nvel_s

		if(iter.gt.1) then
			read(1,*)dvs_old,vvs
		else
			dvs_old=0
			i1=kobr_s(i,1)
			i2=kobr_s(i,2)
			!write(*,*)' i1=',i1,' i2=',i2
			if(i1.eq.0) cycle
			xx=xtop_s(i1,i2)
			yy=ylev_s(i2)
			zz=ztop_s(i1,i2)

			!write(*,*)' xx=',xx,' yy=',yy,' zz=',zz
			vvs=velocity(xx,yy,zz,2)
		end if

		dvs = x(np1+i) * wg_vel_s

		dvs_it(i) = dvs_it(i) + dvs

		dvs_new = dvs_old + dvs_it(i)

		write(11,*)dvs_new,vvs

		avdvs=avdvs+100*abs(dvs)/vvs
	end do
	close(11)
	if(iter.gt.1) close(1)

	avdvs=avdvs/nvel_s
	avdv=0
	do i=1,nst_s
		ii=np3+i
		avdv=avdv+abs(x(ii)*wg_st_s)
	end do
	avstat_s=avdv/nst_s
	open(12,file='../../../DATA/'//ar//'/'//md//'/data/stcor_s_'//it//gr//'.dat')
	do ist=1,nstat
		s_sta(ist)=0
		do i=1,nst_s
			if(ist_s(i).ne.ist) cycle
			ii=np3+i
			s_sta(ist)=x(ii)*wg_st_s
			exit
		end do
		write(12,*)s_sta(ist)
	end do
	close(12)
end if

write(*,*)' total avdv_p=',avdvp,' avdv_s=',avdvs

avdv=0
do i=1,nst_p
	ii=np2+i
	avdv=avdv+abs(x(ii)*wg_st_p)
end do
avstat_p=avdv/nst_p

open(12,file='../../../DATA/'//ar//'/'//md//'/data/stcor_p_'//it//gr//'.dat')
do ist=1,nstat
	p_sta(ist)=0
	do i=1,nst_p
		if(ist_p(i).ne.ist) cycle
		ii=np2+i
		p_sta(ist)=x(ii)*wg_st_p
	end do
	write(12,*)p_sta(ist)
end do
close(12)

write(*,*)' avstat_p=',avstat_p,' avstat_s=',avstat_s

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

open(12,file='../../../DATA/'//ar//'/'//md//'/data/ztcor_'//it//gr//'.dat')
av1=0
av2=0
av3=0
do i=1,nztr
	ii=np4+(i-1)*4
	x_ztr(i)=x_ztr(i)+x(ii+1)*wzt_hor
	y_ztr(i)=y_ztr(i)+x(ii+2)*wzt_hor
	z_ztr(i)=z_ztr(i)+x(ii+3)*wzt_ver
	t_ztr(i)=t_ztr(i)+x(ii+4)*wzt_time
	write(12,*)x_ztr(i),y_ztr(i),z_ztr(i),t_ztr(i)
	av1=av1+sqrt(x_ztr(i)*x_ztr(i)+y_ztr(i)*y_ztr(i))
	av2=av2+abs(z_ztr(i))
	av3=av3+abs(t_ztr(i))
end do
av1=av1/nztr
av2=av2/nztr
av3=av3/nztr
write(*,*)' source corrections:'
write(*,*)' av1=',av1,' av2=',av2,' av3=',av3
close(12)

STOP
end


module feval_module
    use iso_c_binding
    use pf_mod_dtype
    use encap_module
    use pf_mod_utils
    use pf_mod_imex_sweeper
    use pf_mod_rkstepper
    implicit none

    ! Define the derived sweeper type
    type, extends(pf_imex_sweeper_t) :: sweet_sweeper_t
        type(c_ptr)    :: ctx = c_null_ptr ! c pointer to PlaneDataCtx/SphereDataCtx
        integer        :: nnodes           ! number of nodes
        integer        :: sweep_niter      ! number of the current sweep
        integer        :: sweep_niter_max  ! max number of sweeps
        integer        :: level            ! level on which the sweeper is acting
        real(c_double) :: dt               ! full timestep size
    contains
        procedure :: f_eval                => sweet_f_eval
        procedure :: f_comp                => sweet_f_comp
        procedure :: initialize            => sweet_sweeper_initialize
        procedure :: destroy               => sweet_sweeper_destroy
    end type sweet_sweeper_t

    ! prototypes of the C functions

    interface
        subroutine cinitial(i_ctx, i_t, i_dt, o_Y) bind(c, name="cinitial")
            use iso_c_binding
            type(c_ptr),    value :: i_ctx, o_Y
            real(c_double), value :: i_t, i_dt
        end subroutine cinitial

        subroutine cfinal(i_ctx, i_Y, i_nnodes, i_niter) bind(c, name="cfinal")
            use iso_c_binding
            type(c_ptr), value :: i_ctx, i_Y
            integer,     value :: i_nnodes
            integer,     value :: i_niter
        end subroutine cfinal

        subroutine ceval(i_Y, i_t, i_ctx, o_F) bind(c, name="ceval")
            use iso_c_binding
            type(c_ptr),    value :: i_Y, i_ctx, o_F
            real(c_double), value :: i_t
        end subroutine ceval

    end interface

contains

    ! function to cast the pf_sweeper_t object into a sweet_sweeper_t object
    function as_sweet_sweeper(sweeper) result(r)
        class(pf_sweeper_t),    intent(in), target  :: sweeper
        class(sweet_sweeper_t),             pointer :: r

        select type(sweeper)
        type is (sweet_sweeper_t)
            r => sweeper
        class default
            stop "TYPE ERROR"
        end select

    end function as_sweet_sweeper

    ! initialization of the sweet data vector using z

    subroutine finitial(sweeper, sd, z, t, dt)
        class(pf_sweeper_t),       intent(inout) :: sweeper
        class(pf_encap_t),         intent(inout) :: sd
        class(pf_encap_t),         intent(inout) :: z
        real(c_double),            intent(in)    :: t, dt

        class(sweet_sweeper_t),    pointer       :: sweet_sweeper_ptr
        class(sweet_data_encap_t), pointer       :: sd_ptr

        sweet_sweeper_ptr => as_sweet_sweeper(sweeper)
        sd_ptr            => as_sweet_data_encap(sd)

        call cinitial(sweet_sweeper_ptr%ctx, &
                    t,                     &
                    dt,                    &
                    sd_ptr%c_sweet_data_ptr)

        call z%copy(sd)

    end subroutine finitial

    subroutine ffinal(sweeper, sd, nnodes, niter)
        use mpi

        class(pf_sweeper_t),       intent(in)    :: sweeper
        class(pf_encap_t),         intent(inout) :: sd
        integer,                   intent(in)    :: nnodes, niter

        class(sweet_sweeper_t),    pointer       :: sweet_sweeper_ptr
        class(sweet_data_encap_t), pointer       :: sd_ptr

        sweet_sweeper_ptr => as_sweet_sweeper(sweeper)
        sd_ptr            => as_sweet_data_encap(sd)

        call cfinal(sweet_sweeper_ptr%ctx,   &
                    sd_ptr%c_sweet_data_ptr, &
                    nnodes,                  &
                    niter)

    end subroutine ffinal

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    !!             SWEEPER             !!
    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! evaluate the right-hand side

    subroutine sweet_f_eval(this, y, t, level_index, f, piece)
        class(sweet_sweeper_t),    intent(inout) :: this
        class(pf_encap_t),         intent(in)    :: y
        real(pfdp),                intent(in)    :: t
        integer,                   intent(in)    :: level_index
        class(pf_encap_t),         intent(inout) :: f
        integer,                   intent(in)    :: piece

        class(sweet_data_encap_t), pointer       :: y_sd_ptr
        class(sweet_data_encap_t), pointer       :: f_sd_ptr

        y_sd_ptr  => as_sweet_data_encap(y)
        f_sd_ptr  => as_sweet_data_encap(f)

        if (piece == 1) then
            call ceval(y_sd_ptr%c_sweet_data_ptr, &
                    t,                         &
                    this%ctx,                  &
                    f_sd_ptr%c_sweet_data_ptr)
        else
            stop 'Bad value for piece in sweet_f_eval'
        end if

    end subroutine sweet_f_eval

    ! solve for y in the implicit system + update f

    subroutine sweet_f_comp(this, y, t, dtq, rhs, level_index, f, piece)
        class(sweet_sweeper_t),   intent(inout) :: this
        class(pf_encap_t),        intent(inout) :: y, f
        real(pfdp),               intent(in)    :: t, dtq
        class(pf_encap_t),        intent(in)    :: rhs
        integer,                  intent(in)    :: level_index
        integer,                  intent(in)    :: piece

        stop 'sweet_f_comp must not be called (pure explicit SDC)'

    end subroutine sweet_f_comp

    subroutine sweet_sweeper_initialize(this, pf, level_index)
        class(sweet_sweeper_t), intent(inout)        :: this
        type(pf_pfasst_t),      intent(inout),target :: pf
        integer,                intent(in)           :: level_index

        ! call superclass initialize
        call this%imex_initialize(pf, level_index)

        this%implicit=.FALSE.
        this%explicit=.TRUE.
    end subroutine sweet_sweeper_initialize

    ! destructor

    subroutine sweet_sweeper_destroy(this, pf, level_index)
        class(sweet_sweeper_t), intent(inout) :: this
        type(pf_pfasst_t),   intent(inout),target :: pf
        integer,             intent(in)    :: level_index

        ! this is copy-pasted from LibPFASST, unsure about this
        type(pf_level_t), pointer  :: lev       !  Current level
        lev => pf%levels(level_index)           !  Assign level pointer

        ! need the following line since the "final" keyword is not supported by some (older) compilers
        ! it forces Fortran to destroy the parent class data structures
        call this%imex_destroy(pf, level_index)
    end subroutine sweet_sweeper_destroy

end module feval_module


!
! NAME:
!       Compute_MW_Transmittance
!
! PURPOSE:
!       Program to compute channel transmittances for microwave instruments.
!
! SIDE EFFECTS:
!       If the output file already exists, it is overwritten.
!
! CREATION HISTORY:
!       Written by:     Paul van Delst, CIMSS/SSEC 20-Sep-2002
!                       paul.vandelst@ssec.wisc.edu
!

PROGRAM Compute_MW_Transmittance

  ! ------------------
  ! Environment set up
  ! ------------------
  ! Module usage
  USE Type_Kinds                , ONLY : fp
  USE Message_Handler
  USE Profile_Utility_Parameters, ONLY : ID_H2O, &
                                         PPMV_UNITS, &
                                         ND_UNITS, &
                                         MR_UNITS, &
                                         MD_UNITS, &
                                         PP_UNITS
  USE Units_Conversion
  USE SensorInfo_Define
  USE SensorInfo_LinkedList
  USE SensorInfo_IO
  USE AtmProfile_Define
  USE AtmProfile_netCDF_IO
  USE TauProfile_Define
  USE TauProfile_netCDF_IO
  USE MW_SensorData_Define
  USE MWLBL_Transmittance
  ! Disable all implicit typing
  IMPLICIT NONE

  ! ----------
  ! Parameters
  ! ----------
  CHARACTER(*), PARAMETER :: PROGRAM_NAME = 'Compute_MW_Transmittance'
  CHARACTER(*), PARAMETER :: PROGRAM_RCS_ID = &
  ! Keyword argument set value
  INTEGER, PARAMETER :: SET = 1
  ! Direction names
  INTEGER, PARAMETER :: N_DIRECTIONS = 2
  CHARACTER(*), PARAMETER :: DIRECTION_NAME(N_DIRECTIONS) = (/ 'upwelling  ', &
                                                               'downwelling' /)

  ! Model names
  INTEGER, PARAMETER :: N_MODELS = 2
  INTEGER, PARAMETER :: MODEL_LIEBE      = 1
  INTEGER, PARAMETER :: MODEL_ROSENKRANZ = 2
  INTEGER, PARAMETER :: MODEL_INDEX(N_MODELS) = (/ MODEL_LIEBE, &
                                                   MODEL_ROSENKRANZ /)
  CHARACTER(*), PARAMETER :: MODEL_NAME(N_MODELS) = (/ 'Liebe89/93  ', &
                                                       'Rosenkranz03' /)
  ! Define the secant of the zenith angles to be used
  INTEGER, PARAMETER :: N_ANGLES = 7
  REAL(fp), PARAMETER :: ANGLE_SECANT(N_ANGLES) = &
    (/ 1.00_fp, 1.25_fp, 1.50_fp, &
       1.75_fp, 2.00_fp, 2.25_fp, &
       3.00_fp /)
  ! Total number of points per channel. Must be
  ! evenly divisible by 2 and 4.
  INTEGER, PARAMETER :: N_FREQUENCIES = 256
  INTEGER, PARAMETER :: N_HALFPOINTS  = N_FREQUENCIES/2
  ! The molecular set IDs.
  !   1 == WLO; Wet lines only
  !  10 == ALL; All absorbers with continua
  !  12 == WET; Wet (and the wet continua)
  !  13 == DRY; Dry (and the dry continua)
  !  15 == WCO; Wet continua only
  ! 101 == EffWLO; Effective wet lines (wet/wco)
  ! 113 == EffDRY; Effective dry (all/wet)
  INTEGER, PARAMETER :: N_MOLECULE_SETS = 7
  INTEGER, PARAMETER, DIMENSION( N_MOLECULE_SETS ) :: MOLECULE_SET_LIST = &
    (/ 1, 10, 12, 13, 15, 101, 113 /)
  INTEGER, PARAMETER :: WLO_IDX = 1
  INTEGER, PARAMETER :: ALL_IDX = 2
  INTEGER, PARAMETER :: WET_IDX = 3
  INTEGER, PARAMETER :: DRY_IDX = 4
  INTEGER, PARAMETER :: WCO_IDX = 5
  INTEGER, PARAMETER :: EFFECTIVE_WLO_IDX = 6
  INTEGER, PARAMETER :: EFFECTIVE_DRY_IDX = 7
  ! Numeric literal
  REAL(fp), PARAMETER :: ZERO = 0.0_fp
  REAL(fp), PARAMETER :: ONE  = 1.0_fp
  REAL(fp), PARAMETER :: TOLERANCE = EPSILON(ONE)

  ! ---------
  ! Variables
  ! ---------
  CHARACTER(256) :: Message
  INTEGER :: Error_Status
  INTEGER :: Allocate_Status
  INTEGER :: IO_Status
  INTEGER :: Direction
  INTEGER :: Downwelling
  INTEGER :: Model
  INTEGER :: Rosenkranz
  CHARACTER(256)             :: SensorInfo_Filename
  TYPE(SensorInfo_type)      :: SensorInfo
  TYPE(SensorInfo_List_type) :: SensorInfo_List
  CHARACTER(256)        :: AtmProfile_Filename
  TYPE(AtmProfile_type) :: AtmProfile
  CHARACTER(256)        :: TauProfile_Filename
  TYPE(TauProfile_type) :: TauProfile
  CHARACTER(256)        :: Comment
  TYPE(MW_SensorData_type) :: MW_SensorData
  INTEGER :: j ! n_Absorbers
  INTEGER :: k ! n_Layers, n_Levels
  INTEGER :: l ! n_Frequencies
  INTEGER :: m ! n_Profiles
  INTEGER :: n,  n_Sensors
  INTEGER :: n_Points(2)
  INTEGER :: n_OffsetPoints
  INTEGER :: ln
  INTEGER :: i, i_Upper, i_Lower
  CHARACTER(256) :: Profile_Set_ID_Tag
  INTEGER :: j_idx(1)
  INTEGER :: Index_H2O
  REAL(fp), ALLOCATABLE :: H2O_Pressure(:)
  CHARACTER(512) :: MW_SensorData_RCS_Id
  CHARACTER(512) :: MWLBL_Transmittance_RCS_Id
  REAL(fp) :: df, f1, f
  REAL(fp) :: Delta_Frequency
  REAL(fp), ALLOCATABLE         :: Frequency(:)      ! L
  REAL(fp), ALLOCATABLE, TARGET :: TauALL(:,:,:)     ! L x K x I
  REAL(fp), ALLOCATABLE, TARGET :: TauWLO(:,:,:)     ! L x K x I
  REAL(fp), ALLOCATABLE, TARGET :: TauWCO(:,:,:)     ! L x K x I
  REAL(fp), ALLOCATABLE, TARGET :: TauWET(:,:,:)     ! L x K x I
  REAL(fp), ALLOCATABLE, TARGET :: TauDRY(:,:,:)     ! L x K x I
  REAL(fp), POINTER :: Tau(:,:,:) => NULL()
  REAL(fp) :: SumTau, SumError, SumTemp, SumY

  ! Program header
  ! --------------
  CALL Program_Message( PROGRAM_NAME, &
                        'Program to compute transmittance profiles for user-defined '//&
                        'microwave instruments.', &
                        '$Revision$' )

  ! --------------
  ! Get user input
  ! --------------
  ! The calculation direction
  ! -------------------------
  WRITE( *,FMT='(/5x,"Select atmospheric path")' )
  DO i = 1, N_DIRECTIONS
    WRITE( *,FMT='(10x,i1,") ",a)' ) i, DIRECTION_NAME(i)
  END DO
  WRITE( *,FMT='(5x,"Enter choice: ")',ADVANCE='NO' )
  READ( *,FMT='(i5)',IOSTAT=IO_Status ) Direction
  IF ( IO_Status /= 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid ATMOSPHERIC PATH identifier input.', &
                          FAILURE )
    STOP
  END IF
  IF ( Direction < 1 .OR. Direction > N_DIRECTIONS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid ATMOSPERIC PATH identifier value.', &
                          FAILURE )
    STOP
  ENDIF
  ! Upwelling by default....
  Downwelling = 0
  ! ....unless downwelling is selected
  IF ( TRIM( DIRECTION_NAME( Direction ) ) == 'downwelling' ) THEN
    Downwelling = 1
  END IF

  ! The absorption model
  ! --------------------
  WRITE( *,FMT='(/5x,"Select absorption model")' )
  DO i = 1, N_MODELS
    WRITE( *,FMT='(10x,i1,") ",a)' ) i, MODEL_NAME(i)
  END DO
  WRITE( *,FMT='(5x,"Enter choice: ")',ADVANCE='NO' )
  READ( *,FMT='(i5)',IOSTAT=IO_Status ) Model
  IF ( IO_Status /= 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid ABSORPTION MODEL identifier input.', &
                          FAILURE )
    STOP
  END IF
  IF ( Model < 1 .OR. Model > N_MODELS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Invalid ABSORPTION MODEL identifier value.', &
                          FAILURE )
    STOP
  ENDIF
  ! Liebe by default....
  Rosenkranz = 0
  ! ....unless Rosenkranz is selected
  IF ( Model == MODEL_ROSENKRANZ ) THEN
    Rosenkranz = 1
  END IF

  ! The SensorInfo file
  ! -------------------
  WRITE( *,FMT='(/5x,"Enter the SensorInfo filename: ")',ADVANCE='NO' )
  READ( *,FMT='(a)' ) SensorInfo_Filename
  SensorInfo_Filename = ADJUSTL(SensorInfo_Filename)
  ! Read the SensorInfo data
  Error_Status = Read_SensorInfo( SensorInfo_Filename, &
                                  SensorInfo_List, &
                                  Quiet = SET )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME,    &
                          'Error reading SensorInfo file '//TRIM(SensorInfo_Filename), &
                          FAILURE          )
    STOP
  END IF
  ! Count the number of sensors
  n_Sensors = Count_SensorInfo_Nodes( SensorInfo_List )
  IF ( n_Sensors < 1 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'SensorInfo_List is empty.', &
                          FAILURE )
    STOP
  END IF

  ! The AtmProfile file
  ! -------------------
  WRITE( *,FMT='(/5x,"Enter the netCDF AtmProfile filename: ")',ADVANCE='NO' )
  READ( *,'(a)' ) AtmProfile_Filename
  AtmProfile_Filename = ADJUSTL(AtmProfile_Filename)
  ! Read the AtmProfile dataset
  Error_Status = Read_AtmProfile_netCDF( AtmProfile_Filename, &
                                         AtmProfile )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error reading AtmProfile file '//TRIM(AtmProfile_Filename), &
                          Error_Status )
    STOP
  END IF
  ! Get the profile set ID tag
  Profile_Set_ID_Tag = ' '
  Error_Status = Inquire_AtmProfile_netCDF( AtmProfile_Filename, &
                                            ID_Tag=Profile_Set_ID_Tag )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error inquiring AtmProfile input file '//&
                          TRIM(AtmProfile_Filename), &
                          FAILURE )
    STOP
  END IF

  ! Convert water vapour to partial pressure
  ! ----------------------------------------
  ! Determine the H2O index in the absorber array
  n = COUNT( AtmProfile%Absorber_ID == ID_H2O )
  IF ( n == 0 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'No H2O in absorber set.', &
                          FAILURE )
    STOP
  END IF
  IF ( n > 1 ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'More than one H2O identifier in absorber set.', &
                          FAILURE )
    STOP
  END IF
  j_idx = PACK((/(j,j=1,AtmProfile%n_Absorbers)/), &
               AtmProfile%Absorber_ID == ID_H2O )
  Index_H2O = j_idx(1)
  ! Allocate the H2O partial pressure array for units conversion
  ALLOCATE( H2O_Pressure( AtmProfile%n_Layers ), STAT=Allocate_Status )
  IF ( Allocate_Status /= 0 ) THEN
    WRITE( Message,'("Error allocating H2O partial pressure array. STAT = ",i0)' ) &
                    Allocate_Status
    CALL Display_Message( PROGRAM_NAME, &
                          TRIM(Message), &
                          FAILURE )
    STOP
  END IF
  ! Convert the water vapor amounts
  m_H2O_Convert_Loop: DO m = 1, AtmProfile%n_Profiles
    SELECT CASE ( AtmProfile%Absorber_Units_ID( Index_H2O ) )
      ! Convert from ppmv
      CASE ( PPMV_UNITS )
        H2O_Pressure = PPMV_to_PP( AtmProfile%Layer_Pressure(:,m), &
                                   AtmProfile%Layer_Absorber(:,Index_H2O,m) )
      ! Convert from number density
      CASE ( ND_UNITS )
        H2O_Pressure = ND_to_PP( AtmProfile%Layer_Absorber(:,Index_H2O,m), &
                                 AtmProfile%Layer_Temperature(:,m) )
      ! Convert from mixing ratio
      CASE ( MR_UNITS )
        H2O_Pressure = MR_to_PP( AtmProfile%Layer_Pressure(:,m), &
                                 AtmProfile%Layer_Absorber(:,Index_H2O,m) )
      ! Convert from mass density
      CASE ( MD_UNITS )
        H2O_Pressure = MD_to_PP( AtmProfile%Layer_Absorber(:,Index_H2O,m), &
                                 AtmProfile%Layer_Temperature(:,m) )
      ! Partial pressure input
      CASE ( PP_UNITS )
        H2O_Pressure = AtmProfile%Layer_Absorber(:,Index_H2O,m)
      ! Any other input
      CASE DEFAULT
        CALL Display_Message( PROGRAM_NAME, &
                              'Unrecognised water vapour units.', &
                              FAILURE )
        STOP
    END SELECT
    ! Check the result
    IF ( ANY( H2O_Pressure < ZERO ) ) THEN
      WRITE( Message,'("Error converting water vapor units to hPa for AtmProfile #",i0,&
                      &" from ",a,"." )' ) m, TRIM(AtmProfile_Filename)
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM(Message), &
                            FAILURE )
      STOP
    END IF
    ! Save the partial pressure in the structure array
    AtmProfile%Layer_Absorber(:,Index_H2O,m) = H2O_Pressure
  END DO m_H2O_Convert_Loop
  ! Update the absorber units ID
  AtmProfile%Absorber_Units_ID(Index_H2O) = PP_UNITS
  ! Deallocate the H2O partial pressure array
  DEALLOCATE( H2O_Pressure,STAT=Allocate_Status )
  IF ( Allocate_Status /= 0 ) THEN
    WRITE( Message,'("Error deallocating H2O partial pressure array. STAT = ",i0)' ) &
                    Allocate_Status
    CALL Display_Message( PROGRAM_NAME, &
                          TRIM(Message), &
                          WARNING )
  END IF

  ! Allocate the frequency dependent arrays
  ! ---------------------------------------
  ALLOCATE( Frequency( N_FREQUENCIES ), &
            TauALL( N_FREQUENCIES, AtmProfile%n_Layers, N_ANGLES ), &
            TauWLO( N_FREQUENCIES, AtmProfile%n_Layers, N_ANGLES ), &
            TauWCO( N_FREQUENCIES, AtmProfile%n_Layers, N_ANGLES ), &
            TauWET( N_FREQUENCIES, AtmProfile%n_Layers, N_ANGLES ), &
            TauDRY( N_FREQUENCIES, AtmProfile%n_Layers, N_ANGLES ), &
            STAT=Allocate_Status )
  IF ( Allocate_Status /= 0 ) THEN
    Error_Status = FAILURE
    WRITE( Message,'("Error allocating frequency and transmittance arrays. STAT = ",i0)' ) &
                    Allocate_Status
    CALL Display_Message( PROGRAM_NAME, &
                          TRIM(Message), &
                          Error_Status )
    STOP
  END IF

  ! Begin the loop over sensors
  ! ---------------------------
  Sensor_Loop: DO n = 1, n_Sensors

    ! Get the current sensor
    ! ----------------------
    Error_Status = GetFrom_SensorInfo_List( SensorInfo_List, &
                                            n, &
                                            SensorInfo )
    IF ( Error_Status /= SUCCESS ) THEN
      Error_Status = FAILURE
      WRITE( Message,'("Error retrieving SensorInfo data for sensor # ",i0)' ) n
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM(Message), &
                            Error_Status )
      STOP
    END IF

    ! Only process microwave sensors
    ! ------------------------------
    IF ( SensorInfo%Sensor_Type /= MICROWAVE_SENSOR ) CYCLE Sensor_Loop
    ! Output an info message
    WRITE( *,'(//5x,"Calculating ",a," transmittances for ",a,1x,a)' ) &
             TRIM(DIRECTION_NAME( Direction )), &
             TRIM(SensorInfo%Satellite_Name), &
             TRIM(SensorInfo%Sensor_Name)

    ! Load the current microwave sensor data
    ! --------------------------------------
    Error_Status = MW_SensorData_Load( MW_SensorData, &
                                       SensorInfo%Sensor_ID )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error loading MW sensor data for '//&
                            TRIM(SensorInfo%Satellite_Name)//' '//&
                            TRIM(SensorInfo%Sensor_ID), &
                            Error_Status )
      STOP
    END IF

    ! Allocate the TauProfile structure
    ! ---------------------------------
    Error_Status = Allocate_TauProfile( AtmProfile%n_Layers, &
                                        MW_SensorData%n_Channels, &
                                        N_ANGLES, &
                                        AtmProfile%n_Profiles, &
                                        N_MOLECULE_SETS, &
                                        TauProfile )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error allocating TauProfile structure for '//&
                            TRIM(SensorInfo%Satellite_Name)//' '//&
                            TRIM(SensorInfo%Sensor_Name), &
                            Error_Status )
      STOP
    END IF

    ! Begin instrument channel loop
    ! -----------------------------
    Channel_Loop: DO l = 1, MW_SensorData%n_Channels
      WRITE( *,'(10x,"Channel ",i2,"....")' ) MW_SensorData%Sensor_Channel(l)

      ! Compute the frequency grid
      ! --------------------------
      ! First determine the total frequency range in the sidebands
      df = ZERO
      DO ln = 1, MW_SensorData%n_Sidebands( l )
        df = df + ( MW_SensorData%IF_Band(2,ln,l) - MW_SensorData%IF_Band(1,ln,l) )
      END DO
      ! Now determine the frequency interval for this frequency
      ! range to provide the required number of points. Note that
      ! for > 1 sideband channels, the divisor is n-2, not n-1.
      ! This is to exclude the "space" between the sidebands in
      ! the frequency interval calculation. E.g.:
      ! --
      !       Sideband 1             Sideband 2
      !     |-----------|      |-------------------|
      !     x   x   x   x      x   x   x   x   x   x
      !     1   2   3   4      5   6   7   8   9  10   N_HALFPOINTS (n)
      ! --
      !       1   2   3          4   5   6   7   8     INTERVALS    (n-2)
      IF ( MW_SensorData%n_Sidebands( l ) == 1 ) THEN
        Delta_Frequency = df / REAL(N_HALFPOINTS-1,fp)
      ELSE
        Delta_Frequency = df / REAL(N_HALFPOINTS-2,fp)
      END IF
      ! Now determine the number of points for each sideband.
      ! Note that for single sideband channels, this will
      ! *always* be N_HALFPOINTS. For double sideband channels
      ! the points will be split up according to how broad the
      ! the sidebands are. E.g.: If they are the same width, then
      ! we'll get N_HALFPOINTS/2 points per sideband
      n_Points(:) = 0
      DO ln = 1, MW_SensorData%n_Sidebands( l )
        df = MW_SensorData%IF_Band(2,ln,l) - MW_SensorData%IF_Band(1,ln,l)
        n_Points(ln) = NINT(df/Delta_Frequency) + 1
      END DO
      ! Check the result
      IF ( SUM( n_Points ) /= n_HalfPoints ) THEN
        Error_Status = FAILURE
        WRITE( Message,'("Error computing n_HalfPoints for channel ",i2,&
                        &" of ",a,1x,a,". Computed value is ",i0)' ) &
                        MW_SensorData%Sensor_Channel(l), &
                        TRIM(SensorInfo%Satellite_Name), &
                        TRIM(SensorInfo%Sensor_Name), &
                        SUM(n_Points)
        CALL Display_Message( PROGRAM_NAME, &
                              TRIM(Message), &
                              Error_Status )
        STOP
      END IF

      ! Fill the frequency array. It's a bit convoluted as I
      ! want the frequencies to be in ascending order.
      !
      ! For the first sideband loop:
      !
      !   -Sideband2   -Sideband1    F0     +Sideband1   +Sideband2
      !                               ^
      !    |------|   |----------|    |    |----------|   |------|
      !                               |
      !               |<.........|         |.........>|
      !                  n_Lower             n_Upper
      !
      ! For the second sideband loop:
      !
      !                              F0      Sideband1    Sideband2
      !                               ^
      !    |------|   |----------|    |    |----------|   |------|
      !                               |
      !    |<.....|                                       |.....>|
      !     n_Lower                                        n_Upper
      !
      ! -----------------------------------------------------------
      ! Initialise the sideband point offset. This is the
      ! the number of points offset from the central frequency
      ! for a sideband.
      n_OffsetPoints = 0
      ! Loop over the number of sidebands
      DO ln = 1, MW_SensorData%n_Sidebands(l)
        ! Assign the start intermediate frequency for the sideband
        f1 = MW_SensorData%IF_Band( 1, ln, l )
        ! Loop over the number of points in the sideband
        DO i = 1, n_Points( ln )
          ! Determine the positions of the frequencies in the array
          i_Upper = N_HALFPOINTS + n_OffsetPoints + i
          i_Lower = N_HALFPOINTS - n_OffsetPoints - i + 1
          ! Compute the frequency offset
          f = f1 + ( REAL(i-1,fp) * Delta_Frequency )
          ! Apply the offset to the central frequency
          Frequency(i_Upper) = MW_SensorData%Central_Frequency(l) + f
          Frequency(i_Lower) = MW_SensorData%Central_Frequency(l) - f
        END DO
        ! Update the number of offset points
        n_OffsetPoints = n_OffsetPoints + n_Points(ln)
      END DO
      ! Output information on the comp[uted frequency interval
      WRITE( *,'(10x,"Frequency interval for ",a,1x,a,&
                &" channel ",i2,": ",es13.6," GHz")' ) &
                TRIM(SensorInfo%Satellite_Name), &
                TRIM(SensorInfo%Sensor_Name), &
                MW_SensorData%Sensor_Channel(l), &
                Delta_Frequency

      ! Begin loop over atmospheric profiles
      ! ------------------------------------
      Profile_Loop: DO m = 1, AtmProfile%n_Profiles
        WRITE( *,'( 10x,"Processing profile #",i3,"....")' ) m

        ! Call the transmittance function
        ! -------------------------------
        Error_Status = MWLBL_Compute_Tau( AtmProfile%Layer_Pressure(:,m),           &  ! Input
                                          AtmProfile%Layer_Temperature(:,m),        &  ! Input
                                          AtmProfile%Layer_Absorber(:,Index_H2O,m), &  ! Input
                                          AtmProfile%Layer_Delta_Z(:,m),            &  ! Input
                                          ANGLE_SECANT,                             &  ! Input
                                          Frequency,                                &  ! Input
                                          TauALL,                                   &  ! Output
                                          TauWLO,                                   &  ! Output
                                          TauWCO,                                   &  ! Output
                                          TauWET,                                   &  ! Output
                                          TauDRY,                                   &  ! Output
                                          Downwelling=Downwelling,                  &  ! Optional input
                                          Rosenkranz =Rosenkranz,                   &  ! Optional input
                                          Quiet      =1,                            &  ! Optional input
                                          RCS_ID     =MWLBL_Transmittance_RCS_Id    )  ! Revision control
        IF ( Error_Status == FAILURE ) THEN
          WRITE( Message,'("Error computing MW LBL transmittance for profile #",i3,&
                          &", channel ",i2," of ",a,1x,a,".")' ) &
                          m, &
                          MW_SensorData%Sensor_Channel(l), &
                          TRIM(SensorInfo%Satellite_Name), &
                          TRIM(SensorInfo%Sensor_Name)
          CALL Display_Message( PROGRAM_NAME, &
                                TRIM(Message), &
                                FAILURE )
          STOP
        END IF

        ! Average the data over the frequencies, but not
        ! for the effective transmittances
        ! ----------------------------------------------
        DO j = 1, N_MOLECULE_SETS - 2  ! Last two are effective WLO and DRY
          ! Use a pointer to the particular transmittances
          SELECT CASE (j)
            CASE (WLO_IDX)
              Tau => TauWLO
            CASE (ALL_IDX)
              Tau => TauALL
            CASE (WET_IDX)
              Tau => TauWET
            CASE (DRY_IDX)
              Tau => TauDRY
            CASE (WCO_IDX)
              Tau => TauWCO
            CASE DEFAULT
              WRITE( Message,'("Invalid molecule list index found at profile #",i3,&
                              &", channel ",i2," of ",a,1x,a,".")' ) &
                              m, &
                              MW_SensorData%Sensor_Channel(l), &
                              TRIM(SensorInfo%Satellite_Name), &
                              TRIM(SensorInfo%Sensor_Name)
              CALL Display_Message( PROGRAM_NAME, &
                                    TRIM(Message), &
                                    FAILURE )
              STOP
          END SELECT
          ! Loop over the other transmittance dimensions. Note
          ! that the assumption here is that the instrument
          ! channel response is unity for all frequencies in
          ! the band pass.
          DO i = 1, N_ANGLES
            DO k = 1, AtmProfile%n_Layers
              ! Sum over all frequencies using Kahan's
              ! compensated summation algorithm
              SumTau   = ZERO
              SumError = ZERO
              DO ln = 1, N_FREQUENCIES
                SumTemp  = SumTau
                SumY     = Tau(ln,k,i) + SumError
                SumTau   = SumTemp + SumY
                SumError = ( SumTemp - SumTau ) + SumY
              END DO  ! ln
              ! Normalise the result
              TauProfile%Tau(k,l,i,m,j) = SumTau / REAL(N_FREQUENCIES,fp)
            END DO  ! k
          END DO  ! i
        END DO  ! j
        ! Nullify the transmittance array pointer
        NULLIFY( Tau )

        ! Compute the EFFECTIVE transmittances.
        !
        ! Note that using the WHERE construct causes compiler
        ! errors on older SGI compilers.
        ! ---------------------------------------------------
        DO i = 1, N_ANGLES
          DO k = 1, AtmProfile%n_Layers
            ! The EFFECTIVE WLO transmittances
            IF( TauProfile%Tau( k,l,i,m,WCO_IDX ) > TOLERANCE ) THEN
              TauProfile%Tau( k,l,i,m,EFFECTIVE_WLO_IDX ) = TauProfile%Tau( k,l,i,m,WET_IDX ) / &
                                                            TauProfile%Tau( k,l,i,m,WCO_IDX )
            ELSE
              TauProfile%Tau( k,l,i,m,EFFECTIVE_WLO_IDX ) = -ONE
            END IF
            ! The EFFECTIVE DRY transmittances
            IF( TauProfile%Tau( k,l,i,m,WET_IDX ) > TOLERANCE ) THEN
              TauProfile%Tau( k,l,i,m,EFFECTIVE_DRY_IDX ) = TauProfile%Tau( k,l,i,m,ALL_IDX ) / &
                                                            TauProfile%Tau( k,l,i,m,WET_IDX )

            ELSE
              TauProfile%Tau( k,l,i,m,EFFECTIVE_DRY_IDX ) = -ONE
            END IF
          END DO  ! k
        END DO  ! i
      END DO Profile_Loop
    END DO Channel_Loop

    ! Output the TauProfile data
    ! --------------------------
    WRITE( Comment,'("Number of points used per channel in LBL calculation: ",i0,&
                    &". Absorption model used: ",a)' ) &
                    N_FREQUENCIES, MODEL_NAME(Model)
    ! Create the output data file
    TauProfile_Filename = TRIM(DIRECTION_NAME( Direction ))//'.'//&
                          TRIM(SensorInfo%Sensor_Id)//&
                          '.TauProfile.nc'

    Error_Status = Create_TauProfile_netCDF( TauProfile_Filename, &
                                             AtmProfile%Level_Pressure(:,1), &
                                             MW_SensorData%Sensor_Channel, &
                                             ANGLE_SECANT, &
                                             (/ ( m, m = 1, AtmProfile%n_Profiles ) /), &
                                             MOLECULE_SET_LIST, &
                                             Release         =TauProfile%Release, &
                                             Version         =TauProfile%Version, &
                                             Sensor_ID       =SensorInfo%Sensor_ID, &
                                             WMO_Satellite_ID=SensorInfo%WMO_Satellite_ID, &
                                             WMO_Sensor_ID   =SensorInfo%WMO_Sensor_ID, &
                                             ID_Tag = TRIM(PROFILE_SET_ID_TAG), &
                                             Title = TRIM(SensorInfo%Sensor_Name)//' '//&
                                                     TRIM(DIRECTION_NAME( Direction ))//&
                                                     ' transmittances for '//&
                                                     TRIM(SensorInfo%Satellite_Name), &
                                             History = PROGRAM_RCS_ID//'; '//&
                                                       TRIM(MWLBL_Transmittance_RCS_Id),  &
                                             Comment = TRIM(Comment) )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error creating netCDF TauProfile file '//&
                            TRIM(TauProfile_Filename), &
                            Error_Status )
      STOP
    END IF
    ! Write the data to file
    Error_Status = Write_TauProfile_netCDF( TauProfile_Filename, TauProfile )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error writing TauProfile structure for '//&
                            TRIM(SensorInfo%Satellite_Name)//' '//&
                            TRIM(SensorInfo%Sensor_Name)//' to '//&
                            TRIM(TauProfile_Filename), &
                            Error_Status )
      STOP
    END IF

    ! Clean up sensor dependent data structures
    ! -----------------------------------------
    ! Destroy the current TauProfile structure
    Error_Status = Destroy_TauProfile( TauProfile )
    IF ( Error_Status /= SUCCESS ) THEN
      CALL Display_Message( PROGRAM_NAME, &
                            'Error destroying TauProfile structure for '//&
                            TRIM(SensorInfo%Satellite_Name)//' '//&
                            TRIM(SensorInfo%Sensor_Name), &
                            Error_Status )
      STOP
    END IF
    ! Destroy the current microwave sensor data structure
    CALL MW_SensorData_Destroy( MW_SensorData )
!    IF ( Error_Status /= SUCCESS ) THEN
!      CALL Display_Message( PROGRAM_NAME, &
!                            'Error destroying MW_SensorData structure for '//&
!                            TRIM(SensorInfo%Satellite_Name)//' '//&
!                            TRIM(SensorInfo%Sensor_Name), &
!                            Error_Status )
!      STOP
!    END IF
    ! Destroy the SensorInfo structure
    Error_Status = Destroy_SensorInfo( SensorInfo )
    IF ( Error_Status /= SUCCESS ) THEN
      WRITE( Message,'("Error destroying SensorInfo structure for sensor #",i2)' ) n
      CALL Display_Message( PROGRAM_NAME, &
                            TRIM(Message), &
                            Error_Status )
      STOP
    END IF

  END DO Sensor_Loop

  ! Clean up sensor independent data structures
  ! -------------------------------------------
  ! The frequency and transmittance arrays
  DEALLOCATE( Frequency, &
              TauALL, &
              TauWLO, &
              TauWCO, &
              TauWET, &
              TauDRY, &
              STAT = Allocate_Status )
  IF ( Allocate_Status /= 0 ) THEN
    Error_Status = FAILURE
    WRITE( Message,'("Error deallocating frequency and transmittance arrays. STAT = ",i0)' ) &
                    Allocate_Status
    CALL Display_Message( PROGRAM_NAME, &
                          TRIM(Message), &
                          Error_Status )
    STOP
  END IF
  ! Destroy the AtmProfile structure
  Error_Status = Destroy_AtmProfile( AtmProfile )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error destroying AtmProfile structure array.', &
                          WARNING )
  END IF
  ! The linked list
  Error_Status = Destroy_SensorInfo_List( SensorInfo_List )
  IF ( Error_Status /= SUCCESS ) THEN
    CALL Display_Message( PROGRAM_NAME, &
                          'Error destroying SensorInfo linked list.', &
                          WARNING )
  END IF

END PROGRAM Compute_MW_Transmittance


!------------------------------------------------------------------------------!
!  The Community Multiscale Air Quality (CMAQ) system software is in           !
!  continuous development by various groups and is based on information        !
!  from these groups: Federal Government employees, contractors working        !
!  within a United States Government contract, and non-Federal sources         !
!  including research institutions.  These groups give the Government          !
!  permission to use, prepare derivative works of, and distribute copies       !
!  of their work in the CMAQ system to the public and to permit others         !
!  to do so.  The United States Environmental Protection Agency                !
!  therefore grants similar permission to use the CMAQ system software,        !
!  but users are requested to provide copies of derivative works or            !
!  products designed to operate in the CMAQ system to the United States        !
!  Government without restrictions as to use by others.  Software              !
!  that is used with the CMAQ system but distributed under the GNU             !
!  General Public License or the GNU Lesser General Public License is          !
!  subject to their copyright restrictions.                                    !
!------------------------------------------------------------------------------!

SUBROUTINE layht (xx3face, xx3midl, xx3jcbf, xx3jcbm, xx3htf, xx3htm)

!-------------------------------------------------------------------------------
! Name:     Layer Heights
! Purpose:  Compute height of vertical coordinates for given Jacobian.
!              XX3HT =  XX3JACOB * ( X3 (K+1) - X3 (K) )
!
! Input:   IMAX,JMAX:  total domain size in x (E-W) & y (N-S) direction
!          KMAX     :  number of layers (actually used)
!          XX3FACE  :  vertical coordinate values of layer interface
!          XX3MIDL  :  vertical coordinate values of layer middle
!          XX3JCBF  :  vertical Jacobian at layer face in meter
!          XX3JCBM  :  vertical Jacobian at layer middle in meter
!
! Output:  XX3HTF   :  height of layer interface in meter
!          XX3HTM   :  height of layer middle in meter
!
! Revised:  05 Feb 1997  Created for MCIP and generalized CTM.  (D. Byun)
!           18 Sep 2001  Converted to free-form f90.  (T. Otte)
!           09 Jan 2002  Changed calls to "abort" to calls to "m3exit" for
!                        graceful shut-down of I/O API files.  (T. Otte)
!           19 Jun 2006  Removed dependency on module CONST.  (T. Otte)
!           29 Aug 2011  Improved error handling.  (T. Otte)
!           07 Sep 2011  Updated disclaimer.  (T. Otte)
!-------------------------------------------------------------------------------

  IMPLICIT NONE

  INTEGER                           :: i
  INTEGER                           :: imax
  INTEGER                           :: j
  INTEGER                           :: jmax
  INTEGER                           :: k
  INTEGER                           :: lbndf
  INTEGER                           :: lbndm
  CHARACTER(LEN=16),  PARAMETER     :: pname      = 'LAYHT'
  INTEGER                           :: ubndf
  INTEGER                           :: ubndm
  REAL,               INTENT(IN)    :: xx3face    ( : )
  REAL,               INTENT(OUT)   :: xx3htf     ( : , : , : )
  REAL,               INTENT(OUT)   :: xx3htm     ( : , : , : )
  REAL,               INTENT(IN)    :: xx3jcbf    ( : , : , : )
  REAL,               INTENT(IN)    :: xx3jcbm    ( : , : , : )
  REAL,               INTENT(IN)    :: xx3midl    ( : )

!-------------------------------------------------------------------------------
! Error, warning, and informational messages.
!-------------------------------------------------------------------------------

  CHARACTER(LEN=256), PARAMETER :: f9000 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   PROBLEM WITH IMAX', &
    & /, 1x, '***   SIZES OF XX3HTF, XX3HTM = ', 2(2x, i4), &
    & /, 1x, '***   SIZES OF XX3JCBF, XX3JCBM = ', 2(2x, i4), &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=256), PARAMETER :: f9100 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   PROBLEM WITH JMAX', &
    & /, 1x, '***   SIZES OF XX3HTF, XX3HTM = ', 2(2x, i4), &
    & /, 1x, '***   SIZES OF XX3JCBF, XX3JCBM = ', 2(2x, i4), &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=256), PARAMETER :: f9200 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   PROBLEM WITH MIDDLE LEVEL DIMENSION', &
    & /, 1x, '***   SIZE OF XX3MIDL = ', 2x, i4, &
    & /, 1x, '***   SIZES OF XX3HTM, XX3JCBM = ', 2(2x, i4), &
    & /, 1x, 70('*'))"

  CHARACTER(LEN=256), PARAMETER :: f9300 = "(/, 1x, 70('*'), &
    & /, 1x, '*** SUBROUTINE: ', a, &
    & /, 1x, '***   PROBLEM WITH FACE LEVEL DIMENSION', &
    & /, 1x, '***   SIZE OF XX3FACE = ', 2x, i4, &
    & /, 1x, '***   SIZES OF XX3HTF, XX3JCBF = ', 2(2x, i4), &
    & /, 1x, 70('*'))"

!-------------------------------------------------------------------------------
! Since input arrays are assumed-shape, do simple QC on array sizes and
! extract dimension information.
!-------------------------------------------------------------------------------

  ! Check IMAX.

  imax = SIZE(xx3htf,1)
  IF ( ( SIZE(xx3htm,1)  /= imax ) .OR. ( SIZE(xx3jcbf,1) /= imax ) .OR.  &
       ( SIZE(xx3jcbm,1) /= imax ) ) THEN
    WRITE (*,f9000) TRIM(pname), imax, SIZE(xx3htm,1), SIZE(xx3jcbf,1),  &
                    SIZE(xx3jcbm,1)
    CALL graceful_stop (pname)
  ENDIF

  ! Check JMAX.

  jmax = SIZE(xx3htf,2)
  IF ( ( SIZE(xx3htm,2)  /= jmax ) .OR. ( SIZE(xx3jcbf,2) /= jmax ) .OR.  &
       ( SIZE(xx3jcbm,2) /= jmax ) ) THEN
    WRITE (*,f9100) TRIM(pname), jmax, SIZE(xx3htm,2), SIZE(xx3jcbf,2),  &
                    SIZE(xx3jcbm,2)
    CALL graceful_stop (pname)
  ENDIF

  ! Check vertical dimensions.

  IF ( ( SIZE(xx3midl,1) /= SIZE(xx3htm,3)  ) .OR.  &
       ( SIZE(xx3midl,1) /= SIZE(xx3jcbm,3) ) ) THEN
    WRITE (*,f9200) TRIM(pname), SIZE(xx3midl,1), SIZE(xx3htm,3),  &
                    SIZE(xx3jcbm,3)
    CALL graceful_stop (pname)
  ELSE
    lbndm = LBOUND(xx3midl,1)
    ubndm = UBOUND(xx3midl,1)
  ENDIF

  IF ( ( SIZE(xx3face,1) /= SIZE(xx3htf,3)  ) .OR.  &
       ( SIZE(xx3face,1) /= SIZE(xx3jcbf,3) ) ) THEN
    WRITE (*,f9300) TRIM(pname), SIZE(xx3face,1), SIZE(xx3htf,3),  &
                    SIZE(xx3jcbf,3)
    CALL graceful_stop (pname)
  ELSE
    lbndf = LBOUND(xx3face,1)
    ubndf = UBOUND(xx3face,1)
  ENDIF

!-------------------------------------------------------------------------------
! Build layer height fields using Jacobian.
!-------------------------------------------------------------------------------

  DO i = 1, imax
    DO j = 1, jmax

      ! Full levels

      xx3htf(i,j,lbndf) = 0.0

      DO k = lbndf+1, ubndf
        xx3htf(i,j,k) = xx3htf(i,j,k-1) + ( xx3face(k) - xx3face(k-1) ) *  &
                                            xx3jcbm(i,j,lbndm+k-2)
      ENDDO

      ! Half levels

      xx3htm(i,j,lbndm) = ( xx3midl(lbndm) - xx3face(lbndf) )  &
                        * 0.5 * ( xx3jcbf(i,j,lbndf) + xx3jcbm(i,j,lbndm) )

      DO k = lbndm+1, ubndm
        xx3htm(i,j,k) = xx3htm(i,j,k-1) + ( xx3midl(k) - xx3midl(k-1) ) *  &
                                            xx3jcbf(i,j,lbndf+k-1)
      ENDDO

    ENDDO
  ENDDO

END SUBROUTINE layht