      subroutine set_soilveg(me,isot,ivet,nlunit)
      use namelist_soilveg
      implicit none

      integer, intent(in) :: isot,ivet,nlunit
      integer me
!my begin locals
!for 20 igbp veg type and 19 stasgo soil type
      integer i
      REAL WLTSMC1,REFSMC1
! ----------------------------------------------------------------------
! SET TWO SOIL MOISTURE WILT, SOIL MOISTURE REFERENCE PARAMETERS
! ----------------------------------------------------------------------
      REAL SMLOW
      REAL SMLOW_DATA
      DATA SMLOW_DATA /0.5/

      REAL SMHIGH
      REAL SMHIGH_DATA
!     changed in 2.6 from 3 to 6 on June 2nd 2003
!      DATA SMHIGH_DATA /3.0/
      DATA SMHIGH_DATA /6.0/
      NAMELIST /SOIL_VEG/ SLOPE_DATA, RSMTBL, RGLTBL, HSTBL, SNUPX,
     &  BB, DRYSMC, F11, MAXSMC, REFSMC, SATPSI, SATDK, SATDW,
     &  WLTSMC, QTZ, LPARAM, ZBOT_DATA, SALP_DATA, CFACTR_DATA,
     &  CMCMAX_DATA, SBETA_DATA, RSMAX_DATA, TOPT_DATA,
     &  REFDK_DATA, FRZK_DATA, BARE, DEFINED_VEG, DEFINED_SOIL,
     &  DEFINED_SLOPE, FXEXP_DATA, NROOT_DATA, REFKDT_DATA, Z0_DATA,
     &  CZIL_DATA, LAI_DATA, CSOIL_DATA

cmy end locals
      if(ivet.eq.2) then

!using umd veg table
      slope_data =(/0.1,  0.6, 1.0, 0.35, 0.55, 0.8,
     &  	       0.63, 0.0, 0.0, 0.0,  0.0,  0.0,
     &  	       0.0 , 0.0, 0.0, 0.0,  0.0,  0.0,
     &  	       0.0 , 0.0, 0.0, 0.0,  0.0,  0.0,
     &  	       0.0 , 0.0, 0.0, 0.0,  0.0,  0.0/)
      rsmtbl =(/300.0, 175.0, 175.0, 300.0, 300.0, 70.0,
     &              20.0, 225.0, 225.0, 225.0, 400.0, 20.0,
     &  	   150.0,   0.0,   0.0,   0.0,   0.0,  0.0,
     &  	     0.0,   0.0,   0.0,   0.0,   0.0,  0.0,
     &  	     0.0,   0.0,   0.0,   0.0,   0.0,  0.0/)
c-----------------------------
      rgltbl =(/30.0,  30.0,  30.0,  30.0,  30.0,  65.0,
     &  	  100.0, 100.0, 100.0, 100.0, 100.0, 100.0,
     &  	  100.0,   0.0,   0.0,   0.0,	0.0,   0.0,
     &  	    0.0,   0.0,   0.0,   0.0,	0.0,   0.0,
     &  	    0.0,   0.0,   0.0,   0.0,	0.0,   0.0/)
      hstbl =(/41.69, 54.53, 51.93, 47.35,  47.35, 54.53,
     &  	  36.35, 42.00, 42.00, 42.00,  42.00, 36.35,
     &  	  42.00,  0.00,  0.00,  0.00,	0.00,  0.00,
     &  	   0.00,  0.00,  0.00,  0.00,	0.00,  0.00,
     &  	   0.00,  0.00,  0.00,  0.00,	0.00,  0.00/)
!     changed for version 2.6 on june 2nd 2003
!      data snupx  /0.080, 0.080, 0.080, 0.080, 0.080, 0.080,
!     &  	   0.040, 0.040, 0.040, 0.040, 0.025, 0.040,
!     &  	   0.025, 0.000, 0.000, 0.000, 0.000, 0.000,
      snupx  =(/0.040, 0.040, 0.040, 0.040, 0.040, 0.040,
     *             0.020, 0.020, 0.020, 0.020, 0.013, 0.020,
     *             0.013, 0.000, 0.000, 0.000, 0.000, 0.000,
     &  	   0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &  	   0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)

      bare =11

c---------------------------------------------------------------------
! number of defined veg used.
! ----------------------------------------------------------------------
      defined_veg=13
      nroot_data =(/4,4,4,4,4,4,3,3,3,2,3,3,2,0,0,
     &                 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/)
! ----------------------------------------------------------------------
! vegetation class-related arrays
! ----------------------------------------------------------------------
      z0_data =(/2.653, 0.826, 0.563, 1.089, 0.854, 0.856,
     &              0.035, 0.238, 0.065, 0.076, 0.011, 0.125,
     &              0.011, 0.000, 0.000, 0.000, 0.000, 0.000,
     &              0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &              0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
clu: change to 3 or 2   oct 15, 2004
      lai_data =(/3.0, 3.0, 3.0, 3.0, 3.0, 3.0,
     &               3.0, 3.0, 3.0, 3.0, 3.0, 3.0,
     &               3.0, 0.0, 0.0, 0.0, 0.0, 0.0,
     &               0.0, 0.0, 0.0, 0.0, 0.0, 0.0,
     &               0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)
! use igbp table
      elseif(ivet.eq.1)then

      SLOPE_DATA =(/1.0,  1.0, 1.0, 1.0, 1.0, 1.0,
     &                 1.0, 1.0, 1.0, 1.0,  1.0,  1.0,
     &                 1.0 , 1.0, 1.0, 1.0,  1.0,  1.0,
     &                 1.0 , 1.0, 0.0, 0.0,  0.0,  0.0,
     &                 0.0 , 0.0, 0.0, 0.0,  0.0,  0.0/)
      RSMTBL =(/300.0, 300.0, 70.0, 175.0, 175.0, 70.0,
     &              70.0, 70.0, 70.0, 20.0, 40.0, 20.0,
     &             400.0, 35.0, 200.0, 70.0, 100.0, 70.0,
     &             150.0, 200.0, 0.0, 0.0,0.0, 0.0,
     &              0.0, 0.0, 0.0,   0.0,   0.0,  0.0/)
c-----------------------------
      RGLTBL =(/30.0,  30.0,  30.0,  30.0,  30.0,  100.0,
     &            100.0, 65.0, 65.0, 100.0, 100.0, 100.0,
     &            100.0, 100.0, 100.0,100.0,30.0, 100.0,
     &            100.0, 100.0, 0.0,0.0,0.0,0.0,
     &            0.0, 0.0, 0.0,  0.0,  0.0,  0.0/)
      HSTBL =(/47.35, 41.69, 47.35, 54.53, 51.93, 42.00,
     &           42.00, 42.00, 42.00, 36.35, 60.00, 36.25,
     &           42.00, 36.25, 42.00, 42.00, 51.75, 42.00,
     &           42.00, 42.00, 0.00, 0.00, 0.00, 0.00,
     &           0.00, 0.00, 0.00,  0.00,  0.00,  0.00/)
      SNUPX  =(/0.080, 0.080, 0.080, 0.080, 0.080, 0.020,
     *             0.020, 0.060, 0.040, 0.020, 0.010, 0.020,
     *             0.020, 0.020, 0.013, 0.013, 0.010, 0.020,
     &             0.020, 0.020, 0.000, 0.000, 0.000, 0.000,
     &             0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)

      bare =16

!---------------------------------------------------------------------
! number of defined veg used.
! ----------------------------------------------------------------------
      defined_veg=20

      NROOT_DATA =(/4,4,4,4,4,3,3,3,3,3,3,3,1,3,2,
     &                 3,0,3,3,2,0,0,0,0,0,0,0,0,0,0/)
! ----------------------------------------------------------------------
! VEGETATION CLASS-RELATED ARRAYS
! ----------------------------------------------------------------------
      Z0_DATA =(/1.089, 2.653, 0.854, 0.826, 0.80, 0.05,
     &              0.03, 0.856, 0.856, 0.15, 0.04, 0.13,
     &              1.00, 0.25, 0.011, 0.011, 0.001, 0.076,
     &              0.05, 0.03, 0.000, 0.000, 0.000, 0.000,
     &              0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)

      lai_data =(/3.0, 3.0, 3.0, 3.0, 3.0, 3.0,
     &               3.0, 3.0, 3.0, 3.0, 3.0, 3.0,
     &               3.0, 3.0, 3.0, 3.0, 3.0, 3.0,
     &               3.0, 3.0, 0.0, 0.0, 0.0, 0.0,
     &               0.0, 0.0, 0.0, 0.0, 0.0, 0.0/)

!  end if veg table
      endif

      if(isot.eq.0) then

      bb         =(/4.26,  8.72, 11.55, 4.74, 10.73,  8.17,
     &            6.77,  5.25,  4.26, 0.00,  0.00,  0.00,
     &            0.00,  0.00,  0.00, 0.00,  0.00,  0.00,
     &            0.00,  0.00,  0.00, 0.00,  0.00,  0.00,
     &            0.00,  0.00,  0.00, 0.00,  0.00,  0.00/)
! !!!!!!!!!!!!!! the following values in the table are not used
! !!!!!!!!!!!!!! and are just given for reference
      drysmc=(/0.029, 0.119, 0.139, 0.047, 0.100, 0.103,
     &            0.069, 0.066, 0.029, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
! !!!!!!!!!!!!!! the following values in the table are not used
! !!!!!!!!!!!!!! and are just given for reference
      f11  =(/-0.999, -1.116, -2.137, -0.572, -3.201, -1.302,
     &           -1.519, -0.329, -0.999,  0.000,  0.000,  0.000,
     &            0.000,  0.000,  0.000,  0.000,  0.000,  0.000,
     &            0.000,  0.000,  0.000,  0.000,  0.000,  0.000,
     &            0.000,  0.000,  0.000,  0.000,  0.000,  0.000/)
      maxsmc=(/0.421, 0.464, 0.468, 0.434, 0.406, 0.465,
     &            0.404, 0.439, 0.421, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
!
! ----------------------------------------------------------------------
! the following 5 parameters are derived later in redprm.f from the soil
! data, and are just given here for reference and to force static
! storage allocation. -dag lohmann, feb. 2001
! ----------------------------------------------------------------------
!      data refsmc/0.283, 0.387, 0.412, 0.312, 0.338, 0.382,
!     &           0.315, 0.329, 0.283, 0.000, 0.000, 0.000,
! !!!!!!!!!!!!!! the following values in the table are not used
! !!!!!!!!!!!!!! and are just given for reference
      refsmc=(/0.248, 0.368, 0.398, 0.281, 0.321, 0.361,
     &            0.293, 0.301, 0.248, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
! ----------------------------------------------------------------------
! soil texture-related arrays.
! ----------------------------------------------------------------------
      satpsi=(/0.04, 0.62, 0.47, 0.14, 0.10, 0.26,
     &            0.14, 0.36, 0.04, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00/)
      satdk =(/1.41e-5, 0.20e-5, 0.10e-5, 0.52e-5, 0.72e-5,
     &            0.25e-5, 0.45e-5, 0.34e-5, 1.41e-5, 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00/)
      qtz   =(/0.82, 0.10, 0.25, 0.60, 0.52, 0.35,
     &            0.60, 0.40, 0.82, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00/)

! !!!!!!!!!!!!!! the following values in the table are not used
! !!!!!!!!!!!!!! and are just given for reference
      wltsmc=(/0.029, 0.119, 0.139, 0.047, 0.100, 0.103,
     &            0.069, 0.066, 0.029, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
! !!!!!!!!!!!!!! the following values in the table are not used
! !!!!!!!!!!!!!! and are just given for reference
      satdw =(/5.71e-6, 2.33e-5, 1.16e-5, 7.95e-6, 1.90e-5,
     &            1.14e-5, 1.06e-5, 1.46e-5, 5.71e-6, 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00/)

! ----------------------------------------------------------------------
! number of defined soiltyps used.
! ----------------------------------------------------------------------

      defined_soil=9

      else

! using stasgo table
      BB         =(/4.05,  4.26, 4.74, 5.33, 5.33,  5.25,
     &            6.77,  8.72,  8.17, 10.73, 10.39,  11.55,
     &            5.25,  4.26,  4.05, 4.26,  11.55,  4.05,
     &            4.05,  0.00,  0.00, 0.00,  0.00,  0.00,
     &            0.00,  0.00,  0.00, 0.00,  0.00,  0.00/)
! !!!!!!!!!!!!!! The following values in the table are NOT used
! !!!!!!!!!!!!!! and are just given for reference
      DRYSMC=(/0.023, 0.028, 0.047, 0.084, 0.084, 0.066,
     &            0.069, 0.120, 0.103, 0.100, 0.126, 0.135,
     &            0.069, 0.028, 0.012, 0.028, 0.135, 0.012,
     &            0.023, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
! !!!!!!!!!!!!!! The following values in the table are NOT used
! !!!!!!!!!!!!!! and are just given for reference
      F11  =(/-1.090, -1.041, -0.568, 0.162, 0.162, -0.327,
     &           -1.535, -1.118, -1.297, -3.211,  -1.916, -2.258,
     &           -0.201, -1.041, -2.287, -1.041,  -2.258, -2.287,
     &           -1.090,  0.000,  0.000,  0.000,  0.000,  0.000,
     &            0.000,  0.000,  0.000,  0.000,  0.000,  0.000/)
      MAXSMC=(/0.395, 0.421, 0.434, 0.476, 0.476, 0.439,
     &            0.404, 0.464, 0.465, 0.406, 0.468, 0.457,
     &            0.464, 0.421, 0.200, 0.421, 0.457, 0.200,
     &            0.395, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
!
! ----------------------------------------------------------------------
! THE FOLLOWING 5 PARAMETERS ARE DERIVED LATER IN REDPRM.F FROM THE SOIL
! DATA, AND ARE JUST GIVEN HERE FOR REFERENCE AND TO FORCE STATIC
! STORAGE ALLOCATION. -DAG LOHMANN, FEB. 2001
! ----------------------------------------------------------------------
!      DATA REFSMC/0.283, 0.387, 0.412, 0.312, 0.338, 0.382,
!     &           0.315, 0.329, 0.283, 0.000, 0.000, 0.000,
! !!!!!!!!!!!!!! The following values in the table are NOT used
! !!!!!!!!!!!!!! and are just given for reference
      REFSMC=(/0.236, 0.283, 0.312, 0.360, 0.360, 0.329,
     &            0.315, 0.387, 0.382, 0.338, 0.404, 0.403,
     &            0.348, 0.283, 0.133, 0.283, 0.403, 0.133,
     &            0.236, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
! ----------------------------------------------------------------------
! SOIL TEXTURE-RELATED ARRAYS.
! ----------------------------------------------------------------------
      SATPSI=(/0.035, 0.0363, 0.1413, 0.7586, 0.7586, 0.3548,
     &            0.1349, 0.6166, 0.2630, 0.0977, 0.3236, 0.4677,
     &            0.3548, 0.0363, 0.0350, 0.0363, 0.4677, 0.0350,
     &            0.0350, 0.00, 0.00, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00/)
      SATDK =(/1.76e-4, 1.4078e-5, 5.2304e-6, 2.8089e-6, 2.8089e-6,
     &            3.377e-6, 4.4518e-6, 2.0348e-6, 2.4464e-6, 7.2199e-6,
     &           1.3444e-6, 9.7394e-7, 3.377e-6, 1.4078e-5, 1.4087e-05,
     &           1.4078e-5, 9.7394e-7, 1.4078e-5, 1.760e-4, 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00/)
!     QTZ   =(/0.92, 0.82, 0.60, 0.25, 0.10, 0.40,
      QTZ   =(/0.92, 0.82, 0.25, 0.15, 0.10, 0.20,
     &            0.60, 0.10, 0.35, 0.52, 0.10, 0.25,
     &            0.05, 0.25, 0.07, 0.25, 0.60, 0.52,
     &            0.92, 0.00, 0.00, 0.00, 0.00, 0.00,
     &            0.00, 0.00, 0.00, 0.00, 0.00, 0.00/)

! !!!!!!!!!!!!!! The following values in the table are NOT used
! !!!!!!!!!!!!!! and are just given for reference
      WLTSMC=(/0.023, 0.028, 0.047, 0.084, 0.084, 0.066,
     &            0.069, 0.120, 0.103, 0.100, 0.126, 0.135,
     &            0.069, 0.028, 0.012, 0.028, 0.135, 0.012,
     &            0.023, 0.000, 0.000, 0.000, 0.000, 0.000,
     &            0.000, 0.000, 0.000, 0.000, 0.000, 0.000/)
! !!!!!!!!!!!!!! The following values in the table are NOT used
! !!!!!!!!!!!!!! and are just given for reference
      SATDW =(/0.6316e-4, 0.5171e-5, 0.8072e-5, 0.2386e-4, 0.2386e-4,
     &            0.1433e-4, 0.1006e-4, 0.2358e-4, 0.1130e-4,0.1864e-04,
     &           0.9658e-05,0.1151e-04,0.1356e-04,0.5171e-05,0.9978e-05,
     &           0.5171e-05, 0.1151e-04, 0.9978e-05, 0.6316e-04, 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00,
     &            0.00   , 0.00   , 0.00   , 0.00   , 0.00/)
! ----------------------------------------------------------------------
! number of defined soiltyps used.
! ----------------------------------------------------------------------

      defined_soil=19
!   end if soil table
      endif

! the values shared by different veg/soil type data

! PT 5/18/2015 - changed to FALSE to match atm_namelist setting
! PT LPARAM is not used anywhere
!      LPARAM =.TRUE.
      LPARAM =.FALSE.

!     changed for version 2.5.2
!      data zbot_data /-3.0/
      zbot_data =-8.0
!     changed for version 2.6 june 2nd 2003
!      data salp_data /2.6/
      salp_data =4.0
      cfactr_data =0.5
      cmcmax_data =0.5e-3
      sbeta_data =-2.0
      rsmax_data =5000.0
      topt_data =298.0
      refdk_data =2.0e-6
      frzk_data =0.15

      defined_slope=9
      fxexp_data =2.0
      refkdt_data =3.0
!   changed in version 2.6 june 2nd 2003
!      data czil_data /0.2/
      czil_data =0.075

!      DATA CSOIL_DATA /1.26E+6/
      CSOIL_DATA = 2.00E+6
! ----------------------------------------------------------------------
! READ NAMELIST FILE TO OVERRIDE DEFAULT PARAMETERS ONLY ONCE.
! NAMELIST_NAME must be 50 characters or less.
! ----------------------------------------------------------------------
!lu: namelist is set up in run script
!PT         if (me == 0) write(0,*) 'read namelist cwsoilvegSOIL_VEG'
!$$$         READ(5, SOIL_VEG)
!PT         rewind(nlunit)
!PT         READ(nlunit, SOIL_VEG)

!*       WRITE(6, SOIL_VEG)
! 	 OPEN(58, FILE = 'namelist_filename.txt')
!         READ(58,'(A)') NAMELIST_NAME
!         CLOSE(58)
!         WRITE(0,*) 'Namelist Filename is ', NAMELIST_NAME
!         OPEN(59, FILE = NAMELIST_NAME)
! 50      CONTINUE
!         READ(59, SOIL_VEG, END=100)
!         IF (LPARAM) GOTO 50
! 100     CONTINUE
!         CLOSE(59)

         IF (DEFINED_SOIL .GT. MAX_SOILTYP) THEN
            WRITE(0,*) 'Warning: DEFINED_SOIL too large in namelist'
            STOP 222
         ENDIF
         IF (DEFINED_VEG .GT. MAX_VEGTYP) THEN
            WRITE(0,*) 'Warning: DEFINED_VEG too large in namelist'
            STOP 222
         ENDIF
         IF (DEFINED_SLOPE .GT. MAX_SLOPETYP) THEN
            WRITE(0,*) 'Warning: DEFINED_SLOPE too large in namelist'
            STOP 222
         ENDIF

         SMLOW  = SMLOW_DATA
         SMHIGH = SMHIGH_DATA

         DO I = 1,DEFINED_SOIL
           if (satdk(i) /= 0.0 .and. bb(i) > 0.0) then
           SATDW(I)  = BB(I)*SATDK(I)*(SATPSI(I)/MAXSMC(I))
           F11(I)    = ALOG10(SATPSI(I)) + BB(I)*ALOG10(MAXSMC(I)) + 2.0
           REFSMC1   = MAXSMC(I)*(5.79E-9/SATDK(I))
     &                  **(1.0/(2.0*BB(I)+3.0))
           REFSMC(I) = REFSMC1 + (MAXSMC(I)-REFSMC1) / SMHIGH
           WLTSMC1   = MAXSMC(I) * (200.0/SATPSI(I))**(-1.0/BB(I))
           WLTSMC(I) = WLTSMC1 - SMLOW * WLTSMC1

!     ----------------------------------------------------------------------
!     CURRENT VERSION DRYSMC VALUES THAT EQUATE TO WLTSMC.
!     FUTURE VERSION COULD LET DRYSMC BE INDEPENDENTLY SET VIA NAMELIST.
!     ----------------------------------------------------------------------
           DRYSMC(I) = WLTSMC(I)
           endif
         END DO

!       if (me == 0) write(6,soil_veg)
       return
       end


subroutine dropimgood_sel( mt, dk, mk, thr, lt, ut, lp, ph, nx, ny, ppd, coun, pix, gp, mkpx, dar )

!   mt = image
!   dk = dark that will be subtracted from mt
!   mk = mask, masked pixels will not be considered
!   thr = everything below thr will be discarded
!   lt = lower threshold minimum between 0 and 1 photon peak
!   ut = upper threshold minimum between 1 and 2 photon peak
!   lp = length of vector of photons that will be created in memory
!   ph = number of adus per 1 photon
!   ppd = photons per droplet, everything above ppd in a droplet will be discarded.
!           set it to some large number, e.g., 10000, not to exclude anything

    implicit none
!   Input arguments:
    integer(kind=4), intent(in) :: thr, lt, ut, lp, ph, nx, ny, ppd
    real(kind=8), intent(inout), dimension(nx,ny) :: mt
    real(kind=8), intent(in), dimension(nx,ny) :: dk
    integer(kind=4), intent(in), dimension(nx,ny) :: mk

!   Output arguments
    integer(kind=4), intent(out), dimension(nx,ny) :: dar
    integer(kind=4), intent(out), dimension(lp) :: pix, mkpx
    integer(kind=4), intent(out) :: coun, gp

!   Variables used only in subroutine
    integer(kind=4), dimension(nx,ny) :: mto
    integer :: tmp, ifs, ix, iy, st, mx, my, ixx, iyy, bx, ex, by, ey
    integer :: cxj, cyj, iw, j, jjj, cmkp
    integer(kind=4), dimension(lp) :: cx, cy
    real(kind=8) :: fss, mpx, rfs

    !f2py intent(in,out) :: mt

!   this is to dropletize the hole image!!!
!   for wxpcs
!   msumpix, mpix, drop_img = dropimgood_nn(mt,dkimg,lth,bADU,tADU,mNp,ph,nx,ny)
    print *, nx, ny
    coun = 0
    j = 1
    fss = 0.0
    mpx = 0.0
    mx = 0
    my = 0
    st = -1
    iw = 0
    gp = nx*ny
    cmkp = 1
!   Subtract dark (dk) from matrix (mt)
!   and mark pixels below threshold (thr) in mto
    do iy=1,ny,1
        do ix=1,nx,1
            mt(ix,iy)=mt(ix,iy)-dk(ix,iy)
            dar(ix,iy)=0
            mto(ix,iy)=0
            if (mt(ix,iy) .LT. thr .OR. mk(ix,iy) .EQ. 1) then
                mt(ix,iy) = 0.0
                mto(ix,iy) = 1
            endif
            if (mk(ix,iy) .EQ. 1) then
                mkpx(cmkp) = nx*iy+ix
                cmkp = cmkp + 1
                gp = gp - 1
            endif
        end do
    end do
!   Scan matrix for droplets and
!   save the indices of a droplet in cx and cy.
    do iy = 1,ny,1
        do ix = 1,nx,1
            if (mto(ix,iy) .EQ. 0) then
                mto(ix,iy)=1
                st=0
                cx(j)=ix
                cy(j)=iy
                iw=0
            endif
            do while (st .GE. 0)
                iw=iw+1
                cxj=cx(iw)
                cyj=cy(iw)
                st=st-1
                if (cxj-1 .GE. 1) then
                    if (mto(cxj-1,cyj) .EQ. 0) then
                        mto(cxj-1,cyj)=1
                        j=j+1
                        cx(j)=cxj-1
                        cy(j)=cyj
                        st=st+1
                    endif
                endif
                if (cxj+1 .LE. nx) then
                    if (mto(cxj+1,cyj) .EQ. 0) then
                        mto(cxj+1,cyj)=1
                        j=j+1
                        cx(j)=cxj+1
                        cy(j)=cyj
                        st=st+1
                    endif
                endif
                if (cyj-1 .GE. 1) then
                    if (mto(cxj,cyj-1) .EQ. 0) then
                        mto(cxj,cyj-1)=1
                        j=j+1
                        cx(j)=cxj
                        cy(j)=cyj-1
                        st=st+1
                    endif
                endif
                if (cyj+1 .LE. ny) then
                    if (mto(cxj,cyj+1) .EQ. 0) then
                        mto(cxj,cyj+1)=1
                        j=j+1
                        cx(j)=cxj
                        cy(j)=cyj+1
                        st=st+1
                    endif
                endif
            enddo
!           Gather the intensity of a droplet in rfs.
!           Matrix dar contains photon positions.
            if (iw .GE. 1 .AND. iw .LE. ppd) then
                rfs = 0
                do jjj = 1,iw,1
                    rfs = rfs + mt(cx(jjj),cy(jjj))
                end do
                ifs = nint(rfs/ph)
                do while (ifs .GT. 0)
                    mpx = 0.0
                    do jjj = 1,iw,1
                        if (mt(cx(jjj),cy(jjj)) .GT. mpx) then
                            if (mto(cx(jjj),cy(jjj)) .EQ. 1) then
                                mpx = mt(cx(jjj),cy(jjj))
                                mx = cx(jjj)
                                my = cy(jjj)
                            endif
                        endif
                    end do
                    if (mx .EQ. 1) then
                        bx=mx
                        ex=mx+1
                    elseif (mx .EQ. nx) then
                        bx=mx-1
                        ex=mx
                    else
                        bx=mx-1
                        ex=mx+1
                    endif
                    if (my .EQ. 1) then
                        by=my
                        ey=my+1
                    elseif (my .EQ. ny) then
                        by=my-1
                        ey=my
                    else
                        by=my-1
                        ey=my+1
                    endif

                    fss = 0.0
                    do iyy=by,ey,1
                        fss=fss+mt(mx,iyy)
                    end do
                    do ixx=bx,ex,1
                        fss=fss+mt(ixx,my)
                    end do
                    fss = fss - mt(mx,my)

                    if (fss .GE. lt .AND. fss .LE. ut) then
                        dar(mx,my) = 1
                        mt(mx,my) = 0.0
                        mto(mx,my) = 1
                        ifs = ifs - 1
                        rfs = rfs - ph
                    elseif (fss .GT. ut) then
                        if (mpx .LE. ph) then
                            dar(mx,my) = 1
                            mt(mx,my) = 0.0
                            mto(mx,my) = 1
                        elseif (mpx .GT. ph) then
                            dar(mx,my) = nint(mpx/ph)
                            mt(mx,my) = mt(mx,my) - dar(mx,my)*ph
                                if (mt(mx,my) .LT. 0) then
                                    mt(mx,my) = 0.0
                                    mto(mx,my) = 1
                                else
                                    mto(mx,my) = 0
                                endif
                        endif
                        ifs = ifs - dar(mx,my)
                        rfs = rfs - ph*dar(mx,my)
                    else
                        if (rfs .LT. lt .OR. mpx .EQ. 0.0) then
                            mt(mx,my) = 0.0
                            mto(mx,my) = 1
                            ifs = 0
                        else
                            mt(mx,my) = 0.0
                            mto(mx,my) = 1
                        endif
                    endif
                enddo
                do jjj = 1,iw,1
                    mt(cx(jjj),cy(jjj)) = 0.0
                    mto(cx(jjj),cy(jjj)) = 1
                    cx(jjj) = 0
                    cy(jjj) = 0
                end do
            elseif (iw .GT. ppd) then
                do jjj = 1,iw,1
                    mkpx(cmkp) = nx*cy(jjj) + cx(jjj)
                    cmkp = cmkp + 1
                    gp = gp - 1
                    mt(cx(jjj),cy(jjj)) = 0.0
                    mto(cx(jjj),cy(jjj)) = 1
                    cx(jjj) = 0
                    cy(jjj) = 0
                end do
            endif
            j = 1
            st = -1
            iw = 0
        end do
    end do
!   End of main Part. Output is:
!   dar: dropletized image
!   coun: total number of photons
!   pix: linear index of photon positions
    do iy=1,ny,1
        do ix=1,nx,1
            tmp=dar(ix,iy)
            do while (tmp .GT. 0)
                coun=coun+1
                pix(coun)=nx*iy+ix
                tmp=tmp-1
            enddo
        end do
    end do
end subroutine dropimgood_sel


!--------------------------------------------------------------------------------
! Copyright (c) 2018 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_calcDenCoeffs

CONTAINS

SUBROUTINE calcDenCoeffs(atoms,sphhar,sym,we,noccbd,eigVecCoeffs,ispin,denCoeffs)

   USE m_juDFT
   USE m_types_setup
   USE m_types_cdnval, ONLY: t_eigVecCoeffs,t_denCoeffs
   USE m_rhomt
   USE m_rhonmt
   USE m_rhomtlo
   USE m_rhonmtlo

   IMPLICIT NONE

   TYPE(t_atoms),        INTENT(IN)    :: atoms
   TYPE(t_sphhar),       INTENT(IN)    :: sphhar
   TYPE(t_sym),          INTENT(IN)    :: sym
   TYPE(t_eigVecCoeffs), INTENT(IN)    :: eigVecCoeffs
   TYPE(t_denCoeffs),    INTENT(INOUT) :: denCoeffs

   INTEGER,              INTENT(IN)    :: noccbd
   REAL,                 INTENT(IN)    :: we(noccbd)

   INTEGER,              INTENT(IN)    :: ispin

   !--->          set up coefficients for the spherical and
   CALL timestart("cdnval: rhomt")
   CALL rhomt(atoms,we,noccbd,eigVecCoeffs,denCoeffs,ispin)
   CALL timestop("cdnval: rhomt")

   !--->          non-spherical m.t. density
   CALL timestart("cdnval: rhonmt")
   CALL rhonmt(atoms,sphhar,we,noccbd,sym,eigVecCoeffs,denCoeffs,ispin)
   CALL timestop("cdnval: rhonmt")

   !--->          set up coefficients of the local orbitals and the
   !--->          flapw - lo cross terms for the spherical and
   !--->          non-spherical mt density
   CALL timestart("cdnval: rho(n)mtlo")
   CALL rhomtlo(atoms,noccbd,we,eigVecCoeffs,denCoeffs,ispin)

   CALL rhonmtlo(atoms,sphhar,sym,noccbd,we,eigVecCoeffs,denCoeffs,ispin)
   CALL timestop("cdnval: rho(n)mtlo")

END SUBROUTINE calcDenCoeffs

END MODULE m_calcDenCoeffs


C ###############################################################
C #                                                             #
C #                    THE VLIDORT  MODEL                       #
C #                                                             #
C #  Vectorized LInearized Discrete Ordinate Radiative Transfer #
C #  -          --         -        -        -         -        #
C #                                                             #
C ###############################################################

C ###############################################################
C #                                                             #
C #  Author :      Robert. J. D. Spurr                          #
C #                                                             #
C #  Address :      RT Solutions, Inc.                          #
C #            9 Channing Street                                #
C #             Cambridge, MA 02138, USA                        #
C #            Tel: (617) 492 1183                              #
C #                                                             #
C #  Email :      rtsolutions@verizon.net                       #
C #                                                             #
C #  Versions     :   2.0, 2.2, 2.3, 2.4, 2.4R, 2.4RT           #
C #  Release Date :   December 2005  (2.0)                      #
C #  Release Date :   March 2007     (2.2)                      #
C #  Release Date :   October 2007   (2.3)                      #
C #  Release Date :   December 2008  (2.4)                      #
C #  Release Date :   April/May 2009 (2.4R)                     #
C #  Release Date :   July 2009      (2.4RT)                    #
C #                                                             #
C #       NEW: TOTAL COLUMN JACOBIANS         (2.4)             #
C #       NEW: BPDF Land-surface KERNELS      (2.4R)            #
C #       NEW: Thermal Emission Treatment     (2.4RT)           #
C #                                                             #
C ###############################################################

C    #####################################################
C    #                                                   #
C    #   This Version of VLIDORT comes with a GNU-style  #
C    #   license. Please read the license carefully.     #
C    #                                                   #
C    #####################################################

C ###############################################################
C #                                                             #
C # Subroutines in this Module                                  #
C #                                                             #
C #       VLIDORT_L_INTEGRATED_OUTPUT (master)                  #
C #                                                             #
C #            QUADATMOSWF_LEVEL_UP                             #
C #            QUADATMOSWF_LEVEL_DN                             #
C #            QUADATMOSWF_OFFGRID_UP                           #
C #            QUADATMOSWF_OFFGRID_DN                           #
C #                                                             #
C #       VLIDORT_LS_INTEGRATED_OUTPUT (master)                 #
C #                                                             #
C #            QUADSURFACEWF_LEVEL_UP                           #
C #            QUADSURFACEWF_LEVEL_DN                           #
C #            QUADSURFACEWF_OFFGRID_UP                         #
C #            QUADSURFACEWF_OFFGRID_DN                         #
C #                                                             #
C ###############################################################

      SUBROUTINE VLIDORT_L_INTEGRATED_OUTPUT
     &  ( DO_INCLUDE_MVOUTPUT,
     I    DO_INCLUDE_DIRECTBEAM,
     I    DO_INCLUDE_THERMEMISS,
     I    FLUX_MULTIPLIER,
     I    IBEAM, NV, NV_PARAMETERS )

C  Quadrature output at offgrid or ongrid optical depths
C  ( Required if mean-value calculations are to be done)
C    DO_INCLUDE_MVOUTPUT = .TRUE. only for Fourier = 0 )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include file of setup variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'

C  include file of linearized setup variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'

C  include file of result variables (module output stored here)

      INCLUDE '../includes/VLIDORT_L_RESULTS.VARS'

C  Subroutine arguments
C  --------------------

C  Flags

      LOGICAL          DO_INCLUDE_THERMEMISS
      LOGICAL          DO_INCLUDE_DIRECTBEAM
      LOGICAL          DO_INCLUDE_MVOUTPUT

C  Linearization control

      INTEGER          NV, NV_PARAMETERS

C  Beam control

      INTEGER          IBEAM
      DOUBLE PRECISION FLUX_MULTIPLIER

C  local variables
C  ---------------

C  Local quadrature output (for debug)

      DOUBLE PRECISION QATMOSWF_F
     &     ( MAX_ATMOSWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  Help variables

      INTEGER          I, IDIR, WDIR, UTA, UT, Q, N, O1, NLEVEL
      DOUBLE PRECISION SMI, SFX, FTRANS
      DOUBLE PRECISION L_TRANS, L_DIRECT_FLUX, L_DIRECT_MEANI

C  direction loop

      DO IDIR = 1, N_DIRECTIONS
        WDIR = WHICH_DIRECTIONS(IDIR)

C  Upwelling Jacobian output at Quadrature angles

        IF ( WDIR .EQ. UPIDX ) THEN
          DO UTA = 1, N_USER_LEVELS
            NLEVEL = UTAU_LEVEL_MASK_UP(UTA)
            IF ( PARTLAYERS_OUTFLAG(UTA) ) THEN
              UT = PARTLAYERS_OUTINDEX(UTA)
              N  = PARTLAYERS_LAYERIDX(UT)
              CALL QUADATMOSWF_OFFGRID_UP
     &          ( IBEAM, UTA, UT, N, NV, NV_PARAMETERS,
     &            DO_INCLUDE_THERMEMISS, FLUX_MULTIPLIER, QATMOSWF_F )
            ELSE
              CALL QUADATMOSWF_LEVEL_UP
     &          ( UTA, NLEVEL, NV, NV_PARAMETERS,
     &            FLUX_MULTIPLIER, QATMOSWF_F )
            ENDIF
          ENDDO
        ENDIF

C  Downwelling Jacobian output at Quadrature angles

        IF ( WDIR .EQ. DNIDX ) THEN
          DO UTA = 1, N_USER_LEVELS
            NLEVEL = UTAU_LEVEL_MASK_DN(UTA)
            IF ( PARTLAYERS_OUTFLAG(UTA) ) THEN
              UT = PARTLAYERS_OUTINDEX(UTA)
              N  = PARTLAYERS_LAYERIDX(UT)
              CALL QUADATMOSWF_OFFGRID_DN
     &          ( IBEAM, UTA, UT, N, NV, NV_PARAMETERS,
     &            DO_INCLUDE_THERMEMISS, FLUX_MULTIPLIER, QATMOSWF_F )
            ELSE
              CALL QUADATMOSWF_LEVEL_DN
     &          ( UTA, NLEVEL, NV, NV_PARAMETERS,
     &            FLUX_MULTIPLIER, QATMOSWF_F )
            ENDIF
          ENDDO
        ENDIF

C  Mean Intensity and Flux  output
C  -------------------------------

        IF ( DO_INCLUDE_MVOUTPUT ) THEN

C  Diffuse term integrated output

          DO Q = 1, NV_PARAMETERS
           DO UTA = 1, N_USER_LEVELS
            DO O1 = 1, NSTOKES
              SMI = ZERO
              SFX = ZERO
              DO I = 1, NSTREAMS
                SMI = SMI + QUAD_WEIGHTS(I) * QATMOSWF_F(Q,UTA,I,O1)
                SFX = SFX + QUAD_STRMWTS(I) * QATMOSWF_F(Q,UTA,I,O1)
              ENDDO
              MINT_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) = SMI * HALF
              FLUX_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) = SFX * PI2
            ENDDO
           ENDDO
          ENDDO

C  nothing further to do if no solar sources

          IF ( .NOT. DO_INCLUDE_DIRECTBEAM ) GO TO 455

C  For the downward direction, add the direct beam contributions

          IF ( WDIR .EQ. DNIDX ) THEN

C  loop over all the output optical depths

           DO UTA = 1, N_USER_LEVELS

C  For the offgrid values

            IF ( PARTLAYERS_OUTFLAG(UTA) ) THEN
              UT = PARTLAYERS_OUTINDEX(UTA)
              N  = PARTLAYERS_LAYERIDX(UT)

C  For the offgrid values.......
C     .....Only contributions for layers above the PI cutoff
C    L_INITIAL_TRANS is a logarithmic derivative

              IF ( N .LE. LAYER_PIS_CUTOFF(IBEAM) ) THEN
                IF ( NV.LE.N .OR.NV.EQ.0 ) THEN
                 DO Q = 1, NV_PARAMETERS
                  L_TRANS = L_T_UTDN_MUBAR(UT,NV,IBEAM,Q) +
     &           L_INITIAL_TRANS(N,NV,IBEAM,Q) * T_UTDN_MUBAR(UT,IBEAM)
                  L_TRANS = L_TRANS * INITIAL_TRANS(N,IBEAM)
                  DO O1 = 1, NSTOKES
                   FTRANS = FLUXVEC(O1) * L_TRANS
                   L_DIRECT_MEANI = FTRANS / PI4
                   L_DIRECT_FLUX  = FTRANS * LOCAL_CSZA(N,IBEAM)
                   MINT_ATMOSWF_DIRECT(Q,NV,UTA,IBEAM,O1)=L_DIRECT_MEANI
                   FLUX_ATMOSWF_DIRECT(Q,NV,UTA,IBEAM,O1)=L_DIRECT_FLUX
                   MINT_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) =
     *             MINT_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) + L_DIRECT_MEANI
                   FLUX_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) =
     *             FLUX_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) + L_DIRECT_FLUX
                  ENDDO
                 ENDDO
                ENDIF
              ENDIF

C  For the on-grid values
C    L_INITIAL_TRANS is a logarithmic derivative

             ELSE
              N = UTAU_LEVEL_MASK_DN(UTA)
              IF ( N .LE. LAYER_PIS_CUTOFF(IBEAM) ) THEN
               IF ( N.GT.0 ) THEN
                IF ( NV.LE.N .OR.NV.EQ.0 ) THEN
                 DO Q = 1, NV_PARAMETERS
                  L_TRANS = L_T_DELT_MUBAR(N,NV,IBEAM,Q) +
     &             L_INITIAL_TRANS(N,NV,IBEAM,Q) * T_DELT_MUBAR(N,IBEAM)
                  L_TRANS = L_TRANS * INITIAL_TRANS(N,IBEAM)
                  DO O1 = 1, NSTOKES
                   FTRANS = FLUXVEC(O1) * L_TRANS
                   L_DIRECT_MEANI = FTRANS / PI4
                   L_DIRECT_FLUX  = FTRANS * LOCAL_CSZA(N,IBEAM)
                   MINT_ATMOSWF_DIRECT(Q,NV,UTA,IBEAM,O1)=L_DIRECT_MEANI
                   FLUX_ATMOSWF_DIRECT(Q,NV,UTA,IBEAM,O1)=L_DIRECT_FLUX
                   MINT_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) =
     *             MINT_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) + L_DIRECT_MEANI
                   FLUX_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) =
     *             FLUX_ATMOSWF(Q,NV,UTA,IBEAM,O1,WDIR) + L_DIRECT_FLUX
                  ENDDO
                 ENDDO
                ENDIF
               ENDIF
              ENDIF
             ENDIF

C  End UTA loop

           ENDDO

C  Finish downwelling direct contribution

          ENDIF

C  Continuation point for avoiding direct beam calculation

 455      CONTINUE

C  Finish MV output

        ENDIF

C  end direction loop

      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADATMOSWF_LEVEL_UP
     &      ( UTA, NL, NV, NV_PARAMETERS,
     &        FLUX_MULTIPLIER, QATMOSWF_F )

C  Upwelling weighting function Fourier components at level boundary NL
C  Quadrature angles only

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'
      INCLUDE '../includes/VLIDORT_REFLECTANCE.VARS'

C  include files of linearized setup and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          NV, NV_PARAMETERS
      INTEGER          UTA, NL
      DOUBLE PRECISION FLUX_MULTIPLIER

C  output

      DOUBLE PRECISION QATMOSWF_F
     &     ( MAX_ATMOSWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          N, I, I1, Q, O1, K, KO1, K0, K1, K2, LAY
      DOUBLE PRECISION SPAR, SHOM_R, SHOM_CR, SHOM
      DOUBLE PRECISION HOM1, HOM2, HOM1CR, HOM2CR, HOM3CR
      DOUBLE PRECISION NXR, PXR, NXR1, NXR2, PXR1, PXR2
      DOUBLE PRECISION LXR, MXR, LXR1, MXR1, LXR2, MXR2
      DOUBLE PRECISION LLXR, MLXR, LLXR1, MLXR1, LLXR2, MLXR2
      DOUBLE PRECISION TPROP, THELP, L_TPROP, L_THELP, FM

C  homogeneous and particular solution contributions SHOM and SPAR

C  This depends on the level mask - if this is 0 to NLAYERS - 1, then we are
C  looking at the perturbation field at the top of these layers. The
C  case where the level mask = NLAYERS is the upwelling perturbed fields
C  at the bottom of the atmosphere (treated separately).

      N  = NL + 1
      FM = FLUX_MULTIPLIER

C  For the lowest level
C  ====================

C  Thermal transmittance only

      IF ( DO_THERMAL_TRANSONLY .and. NL.EQ.NLAYERS  ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          DO Q = 1, NV_PARAMETERS
            L_THELP = L_BOA_THTONLY_SOURCE(I,Q)
            QATMOSWF_F(Q,UTA,I,O1) = FM * L_THELP
          ENDDO
        ENDDO
        RETURN
      ENDIF

C  For the lowest level, scattering solution
C  -----------------------------------------

      IF ( NL .EQ. NLAYERS ) THEN

C  If this is also the layer that is varying, extra contributions

        IF ( NV .EQ. NL .OR. NV. EQ. 0 ) THEN

C  Stokes and streams loops

          DO I = 1, NSTREAMS
            I1 = I + NSTREAMS
            DO O1 = 1, NSTOKES

C  Parameter loop

              DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

               SHOM_R = ZERO
               DO K = 1, K_REAL(NL)

                LXR  = LCON(K,NL)   *   SOLA_XPOS(I1,O1,K,NL)
                LLXR = LCON(K,NL)   * L_SOLA_XPOS(I1,O1,K,NL,Q)
                MLXR = MCON(K,NL)   * L_SOLB_XNEG(I1,O1,K,NL,Q)
                NXR  = NCON(K,NL,Q) *   SOLA_XPOS(I1,O1,K,NL)
                PXR  = PCON(K,NL,Q) *   SOLB_XNEG(I1,O1,K,NL)

                HOM1 = ( LLXR + NXR )  *   T_DELT_EIGEN(K,NL)
     &                       +  LXR    * L_T_DELT_EIGEN(K,NL,Q)
                HOM2 = PXR + MLXR
                SHOM_R = SHOM_R + HOM1 + HOM2
               ENDDO

C  Complex homogeneous solutions

               SHOM_CR = ZERO
               KO1 = K_REAL(NL) + 1
               DO K = 1, K_COMPLEX(NL)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1

                NXR1  =   NCON(K1,NL,Q) *   SOLA_XPOS(I1,O1,K1,NL)
     &                  - NCON(K2,NL,Q) *   SOLA_XPOS(I1,O1,K2,NL)
                NXR2  =   NCON(K1,NL,Q) *   SOLA_XPOS(I1,O1,K2,NL)
     &                  + NCON(K2,NL,Q) *   SOLA_XPOS(I1,O1,K1,NL)
                PXR1  =   PCON(K1,NL,Q) *   SOLB_XNEG(I1,O1,K1,NL)
     &                  - PCON(K2,NL,Q) *   SOLB_XNEG(I1,O1,K2,NL)

                LXR1  =   LCON(K1,NL) *   SOLA_XPOS(I1,O1,K1,NL)
     &                  - LCON(K2,NL) *   SOLA_XPOS(I1,O1,K2,NL)
                LXR2  =   LCON(K1,NL) *   SOLA_XPOS(I1,O1,K2,NL)
     &                  + LCON(K2,NL) *   SOLA_XPOS(I1,O1,K1,NL)

                LLXR1  =   LCON(K1,NL) * L_SOLA_XPOS(I1,O1,K1,NL,Q)
     &                   - LCON(K2,NL) * L_SOLA_XPOS(I1,O1,K2,NL,Q)
                LLXR2  =   LCON(K1,NL) * L_SOLA_XPOS(I1,O1,K2,NL,Q)
     &                   + LCON(K2,NL) * L_SOLA_XPOS(I1,O1,K1,NL,Q)
                MLXR1  =   MCON(K1,NL) * L_SOLB_XNEG(I1,O1,K1,NL,Q)
     &                   - MCON(K2,NL) * L_SOLB_XNEG(I1,O1,K2,NL,Q)

                HOM1CR =   ( NXR1 + LLXR1 ) *   T_DELT_EIGEN(K1,NL)
     &                   - ( NXR2 + LLXR2 ) *   T_DELT_EIGEN(K2,NL)
                HOM2CR =             LXR1   * L_T_DELT_EIGEN(K1,NL,Q)
     &                             - LXR2   * L_T_DELT_EIGEN(K2,NL,Q)
                HOM3CR = PXR1 + MLXR1
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR + HOM3CR
               ENDDO

C  real part, add particular solution, complete result

               SHOM = SHOM_R + SHOM_CR
               SPAR = L_WLOWER(I1,O1,NL,Q)
               QATMOSWF_F(Q,UTA,I,O1) = FM * ( SPAR + SHOM )

C  Finish Q, I and O1 loops

              ENDDO
            ENDDO
          ENDDO

C  non-varying lowest layer

        ELSE IF ( NV.LT.NL .AND. NV.NE.0 ) THEN

C  Stokes and streams loops

          DO I = 1, NSTREAMS
            I1 = I + NSTREAMS
            DO O1 = 1, NSTOKES

C  Parameter loop

              DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

               SHOM_R = ZERO
               DO K = 1, K_REAL(NL)
                NXR = NCON(K,NL,Q) *   SOLA_XPOS(I1,O1,K,NL)
                PXR = PCON(K,NL,Q) *   SOLB_XNEG(I1,O1,K,NL)
                HOM1 = NXR * T_DELT_EIGEN(K,NL)
                HOM2 = PXR
                SHOM_R = SHOM_R + HOM1 + HOM2
               ENDDO

C  Complex homogeneous solutions

               SHOM_CR = ZERO
               KO1 = K_REAL(NL) + 1
               DO K = 1, K_COMPLEX(NL)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1
                NXR1  =   NCON(K1,NL,Q) *   SOLA_XPOS(I1,O1,K1,NL)
     &                  - NCON(K2,NL,Q) *   SOLA_XPOS(I1,O1,K2,NL)
                NXR2  =   NCON(K1,NL,Q) *   SOLA_XPOS(I1,O1,K2,NL)
     &                  + NCON(K2,NL,Q) *   SOLA_XPOS(I1,O1,K1,NL)
                PXR1  =   PCON(K1,NL,Q) *   SOLB_XNEG(I1,O1,K1,NL)
     &                  - PCON(K2,NL,Q) *   SOLB_XNEG(I1,O1,K2,NL)
                HOM1CR =   NXR1 * T_DELT_EIGEN(K1,NL)
     &                   - NXR2 * T_DELT_EIGEN(K2,NL)
                HOM2CR = PXR1
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR
               ENDDO

C  real part, add particular solution, complete result

               SHOM = SHOM_R + SHOM_CR
               SPAR = L_WLOWER(I1,O1,NL,Q)
               QATMOSWF_F(Q,UTA,I,O1) = FM * ( SPAR + SHOM )

C  Finish Q, I and O1 loops

              ENDDO
            ENDDO
          ENDDO

        ENDIF

C  End lowest level clause

      ENDIF

C  For other levels in the atmosphere
C  ==================================

C  For other levels, thermal transmittance only

      IF ( NL .NE. NLAYERS .and. DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          I1 = I + NSTREAMS
          DO Q = 1, NV_PARAMETERS
            L_THELP = L_BOA_THTONLY_SOURCE(I,Q)
            THELP   =   BOA_THTONLY_SOURCE(I)
            DO LAY = NLAYERS, N, -1
              L_THELP = L_THELP * T_DELT_DISORDS(I,LAY)
              IF ( LAY.EQ.NV .OR. NV.EQ.0 ) THEN
                L_TPROP = L_T_WUPPER(I1,LAY,Q) / QUAD_STREAMS(I)
                L_THELP = L_THELP + L_TPROP
     &                    + THELP * L_T_DELT_DISORDS(I,LAY,Q)
              ENDIF
              TPROP = T_WUPPER(I1,LAY) / QUAD_STREAMS(I)
              THELP = THELP * T_DELT_DISORDS(I,LAY) + TPROP
            ENDDO
            QATMOSWF_F(Q,UTA,I,O1) = FM * L_THELP
          ENDDO
        ENDDO
        RETURN
      ENDIF

C  For other levels, scattering solution
C  -------------------------------------

      IF ( NL .NE. NLAYERS ) THEN

C  If this is also the layer that is varying, extra contributions

        IF ( NV .EQ. N .OR. NV. EQ. 0 ) THEN

C  Stokes and streams loops

          DO I = 1, NSTREAMS
            I1 = I + NSTREAMS
            DO O1 = 1, NSTOKES

C  Parameter loop

              DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

               SHOM_R = ZERO
               DO K = 1, K_REAL(N)
                LXR  = LCON(K,N)   *   SOLA_XPOS(I1,O1,K,N)
                MXR  = MCON(K,N)   *   SOLB_XNEG(I1,O1,K,N)
                LLXR = LCON(K,N)   * L_SOLA_XPOS(I1,O1,K,N,Q)
                MLXR = MCON(K,N)   * L_SOLB_XNEG(I1,O1,K,N,Q)
                NXR  = NCON(K,N,Q) *   SOLA_XPOS(I1,O1,K,N)
                PXR  = PCON(K,N,Q) *   SOLB_XNEG(I1,O1,K,N)
                HOM1 =   NXR + LLXR
                HOM2 = ( PXR + MLXR ) *   T_DELT_EIGEN(K,N)
     &                       + MXR    * L_T_DELT_EIGEN(K,N,Q)
                SHOM_R = SHOM_R + HOM1 + HOM2
               ENDDO

C  Complex homogeneous solutions

               SHOM_CR = ZERO
               KO1 = K_REAL(N) + 1
               DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1

                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I1,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I1,O1,K2,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
                PXR2  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
     &                  + PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K1,N)

                MXR1  =   MCON(K1,N) *   SOLB_XNEG(I1,O1,K1,N)
     &                  - MCON(K2,N) *   SOLB_XNEG(I1,O1,K2,N)
                MXR2  =   MCON(K1,N) *   SOLB_XNEG(I1,O1,K2,N)
     &                  + MCON(K2,N) *   SOLB_XNEG(I1,O1,K1,N)

                LLXR1  =   LCON(K1,N) * L_SOLA_XPOS(I1,O1,K1,N,Q)
     &                   - LCON(K2,N) * L_SOLA_XPOS(I1,O1,K2,N,Q)
                MLXR1  =   MCON(K1,N) * L_SOLB_XNEG(I1,O1,K1,N,Q)
     &                   - MCON(K2,N) * L_SOLB_XNEG(I1,O1,K2,N,Q)
                MLXR2  =   MCON(K1,N) * L_SOLB_XNEG(I1,O1,K2,N,Q)
     &                   + MCON(K2,N) * L_SOLB_XNEG(I1,O1,K1,N,Q)

                HOM1CR =   ( PXR1 + MLXR1 ) *   T_DELT_EIGEN(K1,N)
     &                   - ( PXR2 + MLXR2 ) *   T_DELT_EIGEN(K2,N)
                HOM2CR =             MXR1   * L_T_DELT_EIGEN(K1,N,Q)
     &                             - MXR2   * L_T_DELT_EIGEN(K2,N,Q)
                HOM3CR = NXR1 + LLXR1
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR + HOM3CR

               ENDDO

C  real part, add particular solution, complete result

               SHOM = SHOM_R + SHOM_CR
               SPAR = L_WUPPER(I1,O1,N,Q)
               QATMOSWF_F(Q,UTA,I,O1) = FLUX_MULTIPLIER * (SPAR+SHOM)

C  Finish Q, I and O1 loops

              ENDDO
            ENDDO
          ENDDO

C  For layers N beneath or above the varying layer NV

        ELSE IF ( NV.NE.N .AND. NV.NE.0 ) THEN

C  Stokes and streams loops

          DO I = 1, NSTREAMS
            I1 = I + NSTREAMS
            DO O1 = 1, NSTOKES

C  Parameter loop

              DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

               SHOM_R = ZERO
               DO K = 1, K_REAL(N)
                NXR  = NCON(K,N,Q) *   SOLA_XPOS(I1,O1,K,N)
                PXR  = PCON(K,N,Q) *   SOLB_XNEG(I1,O1,K,N)
                HOM1 = NXR
                HOM2 = PXR * T_DELT_EIGEN(K,N)
                SHOM_R = SHOM_R + HOM1 + HOM2
               ENDDO

C  Complex homogeneous solutions

               SHOM_CR = ZERO
               KO1 = K_REAL(N) + 1
               DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1
                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I1,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I1,O1,K2,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
                PXR2  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
     &                  + PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K1,N)
                HOM1CR =   PXR1 * T_DELT_EIGEN(K1,N)
     &                   - PXR2 * T_DELT_EIGEN(K2,N)
                HOM2CR = NXR1
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR
               ENDDO

C  real part, add particular solution (only if N>NV), complete result

               SHOM = SHOM_R + SHOM_CR
               SPAR = ZERO
               IF (NV.LT.N)SPAR = L_WUPPER(I1,O1,N,Q)
               QATMOSWF_F(Q,UTA,I,O1) = FLUX_MULTIPLIER * (SPAR+SHOM)

C  Finish Q, I and O1 loops

              ENDDO
            ENDDO
          ENDDO

C  End variability clauses

        ENDIF
      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADATMOSWF_LEVEL_DN
     &      ( UTA, NL, NV, NV_PARAMETERS,
     &        FLUX_MULTIPLIER, QATMOSWF_F )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  include files of linearized setup and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          NV, NV_PARAMETERS
      INTEGER          UTA, NL
      DOUBLE PRECISION FLUX_MULTIPLIER

C  output

      DOUBLE PRECISION QATMOSWF_F
     &     ( MAX_ATMOSWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          N, I, Q, O1, K, KO1, K0, K1, K2, LAY
      DOUBLE PRECISION SPAR, SHOM_R, SHOM_CR, SHOM
      DOUBLE PRECISION HOM1, HOM2, HOM1CR, HOM2CR, HOM3CR
      DOUBLE PRECISION NXR, PXR, NXR1, NXR2, PXR1
      DOUBLE PRECISION LXR, LXR1, LXR2
      DOUBLE PRECISION LLXR, MLXR, LLXR1, MLXR1, LLXR2
      DOUBLE PRECISION TPROP, THELP, L_TPROP, L_THELP, FM

C  Downwelling weighting function at TOA ( or N = 0 ) is zero
C    Zero and return

      IF ( NL .EQ. 0 ) THEN
        DO I = 1, NSTREAMS
          DO Q = 1, NV_PARAMETERS
            DO O1 = 1, NSTOKES
              QATMOSWF_F(Q,UTA,I,O1) = ZERO
            ENDDO
          ENDDO
        ENDDO
        RETURN
      ENDIF

C  For other levels in the atmosphere
C  ----------------------------------

C  Other levels, Thermal transmittance-only solution
C  Thermal transmittance solution, build from TOA downwards
C  Scattering solution, use the Discrete Ordinate solution

      IF ( NL.NE.0 .and. DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          DO Q = 1, NV_PARAMETERS
            L_THELP = ZERO
            THELP   = ZERO
            DO LAY = 1, N
              L_THELP = L_THELP * T_DELT_DISORDS(I,LAY)
              IF ( LAY.EQ.NV .OR. NV.EQ.0 ) THEN
                L_TPROP = L_T_WLOWER(I,LAY,Q) / QUAD_STREAMS(I)
                L_THELP = L_THELP +  L_TPROP
     &                    + THELP * L_T_DELT_DISORDS(I,LAY,Q)
              ENDIF
              TPROP = T_WLOWER(I,LAY) / QUAD_STREAMS(I)
              THELP = THELP * T_DELT_DISORDS(I,LAY) + TPROP
            ENDDO
            QATMOSWF_F(Q,UTA,I,O1) = FM * L_THELP
          ENDDO
        ENDDO
        RETURN
      ENDIF

C  Scattering solutions
C  --------------------

      IF ( NL.NE.0 ) THEN

C  Shorthand

        N = NL

C  If this is also the layer that is varying, extra contributions

        IF ( NV .EQ. N .OR. NV.EQ.0 ) THEN

C  Stokes and streams loops

          DO I = 1, NSTREAMS
            DO O1 = 1, NSTOKES

C  Parameter loop

              DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

               SHOM_R = ZERO
               DO K = 1, K_REAL(N)
                LXR  = LCON(K,N)   *   SOLA_XPOS(I,O1,K,N)
                LLXR = LCON(K,N)   * L_SOLA_XPOS(I,O1,K,N,Q)
                MLXR = MCON(K,N)   * L_SOLB_XNEG(I,O1,K,N,Q)
                NXR  = NCON(K,N,Q) *   SOLA_XPOS(I,O1,K,N)
                PXR  = PCON(K,N,Q) *   SOLB_XNEG(I,O1,K,N)
                HOM1 = ( NXR + LLXR ) *   T_DELT_EIGEN(K,N)
     &                       +  LXR   * L_T_DELT_EIGEN(K,N,Q)
                HOM2 = PXR + MLXR
                SHOM_R = SHOM_R + HOM1 + HOM2
               ENDDO

C  Complex homogeneous solutions

               SHOM_CR = ZERO
               KO1 = K_REAL(N) + 1
               DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1

                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K2,N)
                NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K2,N)
     &                  + NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K1,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K2,N)

                LXR1  =   LCON(K1,N) *   SOLA_XPOS(I,O1,K1,N)
     &                  - LCON(K2,N) *   SOLA_XPOS(I,O1,K2,N)
                LXR2  =   LCON(K1,N) *   SOLA_XPOS(I,O1,K2,N)
     &                  + LCON(K2,N) *   SOLA_XPOS(I,O1,K1,N)

                LLXR1  =   LCON(K1,N) * L_SOLA_XPOS(I,O1,K1,N,Q)
     &                   - LCON(K2,N) * L_SOLA_XPOS(I,O1,K2,N,Q)
                LLXR2  =   LCON(K1,N) * L_SOLA_XPOS(I,O1,K2,N,Q)
     &                   + LCON(K2,N) * L_SOLA_XPOS(I,O1,K1,N,Q)
                MLXR1  =   MCON(K1,N) * L_SOLB_XNEG(I,O1,K1,N,Q)
     &                   - MCON(K2,N) * L_SOLB_XNEG(I,O1,K2,N,Q)

                HOM1CR =   ( NXR1 + LLXR1 ) *   T_DELT_EIGEN(K1,N)
     &                   - ( NXR2 + LLXR2 ) *   T_DELT_EIGEN(K2,N)
                HOM2CR =             LXR1   * L_T_DELT_EIGEN(K1,N,Q)
     &                             - LXR2   * L_T_DELT_EIGEN(K2,N,Q)
                HOM3CR = PXR1 + MLXR1
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR + HOM3CR

               ENDDO

C  real part, add particular solution, complete result

               SHOM = SHOM_R + SHOM_CR
               SPAR = L_WLOWER(I,O1,N,Q)
               QATMOSWF_F(Q,UTA,I,O1) = FLUX_MULTIPLIER * (SPAR+SHOM)

C  Finish Q, I and O1 loops

              ENDDO
            ENDDO
          ENDDO

C  varying layer above or below active layer

        ELSE IF ( NV.NE.N .AND. NV.NE.0 ) THEN

C  Stokes and streams loops

          DO I = 1, NSTREAMS
            DO O1 = 1, NSTOKES

C  Parameter loop

              DO Q = 1, NV_PARAMETERS

C  Real homogeneous solutions

               SHOM_R = ZERO
               DO K = 1, K_REAL(N)
                NXR = NCON(K,N,Q) *   SOLA_XPOS(I,O1,K,N)
                PXR = PCON(K,N,Q) *   SOLB_XNEG(I,O1,K,N)
                HOM1 = NXR * T_DELT_EIGEN(K,N)
                HOM2 = PXR
                SHOM_R = SHOM_R + HOM1 + HOM2
               ENDDO

C  Complex homogeneous solutions

               SHOM_CR = ZERO
               KO1 = K_REAL(N) + 1
               DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1
                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K2,N)
                NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K2,N)
     &                  + NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K1,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K2,N)
                HOM1CR =   NXR1 * T_DELT_EIGEN(K1,N)
     &                   - NXR2 * T_DELT_EIGEN(K2,N)
                HOM2CR = PXR1
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR
               ENDDO

C  real part, add particular solution (only if N > NV), complete result

               SHOM = SHOM_R + SHOM_CR
               SPAR = ZERO
               IF ( N .GT. NV ) SPAR = L_WLOWER(I,O1,N,Q)
               QATMOSWF_F(Q,UTA,I,O1) = FLUX_MULTIPLIER * (SPAR+SHOM)

C  Finish Q, I and O1 loops

              ENDDO
            ENDDO
          ENDDO

C  Finish variability clauses

        ENDIF
      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADATMOSWF_OFFGRID_UP
     &     ( IB, UTA, UT, N, NV, NV_PARAMETERS,
     &       DO_INCLUDE_THERMEMISS, FLUX_MULTIPLIER, QATMOSWF_F )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'
      INCLUDE '../includes/VLIDORT_REFLECTANCE.VARS'

C  include files of linearized setup/solution/multiplier variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          NV, NV_PARAMETERS
      INTEGER          IB, UTA, UT, N

      DOUBLE PRECISION FLUX_MULTIPLIER
      LOGICAL          DO_INCLUDE_THERMEMISS

C  output

      DOUBLE PRECISION QATMOSWF_F
     &     ( MAX_ATMOSWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          I, I1, Q, O1, K, KO1, K0, K1, K2, LAY
      DOUBLE PRECISION SPAR, SHOM_R, SHOM_CR, SHOM
      DOUBLE PRECISION HOM1, HOM2, HOM1CR, HOM2CR, HOM3CR, HOM4CR
      DOUBLE PRECISION NXR, PXR, NXR1, NXR2, PXR1, PXR2
      DOUBLE PRECISION LXR, MXR, LXR1, MXR1, LXR2, MXR2
      DOUBLE PRECISION LLXR, MLXR, LLXR1, MLXR1, LLXR2, MLXR2
      DOUBLE PRECISION TPROP, THELP, L_TPROP, L_THELP, FMULT

C  short hand

      FMULT = FLUX_MULTIPLIER

C  Thermal Transmittance only
c  --------------------------

      IF ( DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          I1 = I + NSTREAMS
          DO Q = 1, NV_PARAMETERS
            THELP     =   BOA_THTONLY_SOURCE(I)
            L_THELP   = L_BOA_THTONLY_SOURCE(I,Q)
            DO LAY = NLAYERS, N+1, -1
              L_THELP = L_THELP *   T_DELT_DISORDS(I,LAY)
              IF ( LAY.EQ.NV .OR. NV.EQ.0 ) THEN
                L_TPROP = L_T_WUPPER(I1,LAY,Q) / QUAD_STREAMS(I)
                L_THELP = L_THELP + L_TPROP
     &                    + THELP * L_T_DELT_DISORDS(I,LAY,Q)
              ENDIF
              TPROP = T_WUPPER(I1,Q) / QUAD_STREAMS(I)
              THELP = THELP * T_DELT_DISORDS(I,LAY) + TPROP
            ENDDO
            L_THELP = L_THELP * T_DISORDS_UTUP(I,UT)
            IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
              L_TPROP = L_UT_T_PARTIC(I1,UT,Q) / QUAD_STREAMS(I)
              L_THELP = L_THELP + L_TPROP
     &                  + THELP * L_T_DISORDS_UTUP(I,UT,Q)
            ENDIF
            QATMOSWF_F(Q,UTA,I,O1) = FMULT * L_THELP
          ENDDO
        ENDDO
        RETURN
      ENDIF

C  For those optical depths at off-grid levels
C  ###########################################

C  Homogeneous
C  -----------

C  solution for N being the varying layer NV

      IF ( N. EQ. NV .OR. NV.EQ.0 ) THEN

C  stream directions

        DO I = 1, NSTREAMS
          I1 = I + NSTREAMS
          DO O1 = 1, NSTOKES

C  Parameter loop

            DO Q = 1, NV_PARAMETERS

C  real homogeneous solutions

              SHOM_R = ZERO
              DO K = 1, K_REAL(N)
                LXR  = LCON(K,N)   *   SOLA_XPOS(I1,O1,K,N)
                MXR  = MCON(K,N)   *   SOLB_XNEG(I1,O1,K,N)
                LLXR = LCON(K,N)   * L_SOLA_XPOS(I1,O1,K,N,Q)
                MLXR = MCON(K,N)   * L_SOLB_XNEG(I1,O1,K,N,Q)
                NXR  = NCON(K,N,Q) *   SOLA_XPOS(I1,O1,K,N)
                PXR  = PCON(K,N,Q) *   SOLB_XNEG(I1,O1,K,N)
                HOM1 = ( NXR + LLXR ) *   T_UTDN_EIGEN(K,UT)
     &                       +  LXR   * L_T_UTDN_EIGEN(K,UT,Q)
                HOM2 = ( PXR + MLXR ) *   T_UTUP_EIGEN(K,UT)
     &                       +  MXR   * L_T_UTUP_EIGEN(K,UT,Q)
                SHOM_R = SHOM_R + HOM1 + HOM2
              ENDDO

C  complex homogeneous solutions

              SHOM_CR = ZERO
              KO1 = K_REAL(N) + 1
              DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1

                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I1,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I1,O1,K2,N)
                NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I1,O1,K2,N)
     &                  + NCON(K2,N,Q) *   SOLA_XPOS(I1,O1,K1,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
                PXR2  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
     &                  + PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K1,N)

                LXR1  =   LCON(K1,N) *   SOLA_XPOS(I1,O1,K1,N)
     &                  - LCON(K2,N) *   SOLA_XPOS(I1,O1,K2,N)
                LXR2  =   LCON(K1,N) *   SOLA_XPOS(I1,O1,K2,N)
     &                  + LCON(K2,N) *   SOLA_XPOS(I1,O1,K1,N)
                MXR1  =   MCON(K1,N) *   SOLB_XNEG(I1,O1,K1,N)
     &                  - MCON(K2,N) *   SOLB_XNEG(I1,O1,K2,N)
                MXR2  =   MCON(K1,N) *   SOLB_XNEG(I1,O1,K2,N)
     &                  + MCON(K2,N) *   SOLB_XNEG(I1,O1,K1,N)

                LLXR1  =   LCON(K1,N) * L_SOLA_XPOS(I1,O1,K1,N,Q)
     &                   - LCON(K2,N) * L_SOLA_XPOS(I1,O1,K2,N,Q)
                LLXR2  =   LCON(K1,N) * L_SOLA_XPOS(I1,O1,K2,N,Q)
     &                   + LCON(K2,N) * L_SOLA_XPOS(I1,O1,K1,N,Q)
                MLXR1  =   MCON(K1,N) * L_SOLB_XNEG(I1,O1,K1,N,Q)
     &                   - MCON(K2,N) * L_SOLB_XNEG(I1,O1,K2,N,Q)
                MLXR2  =   MCON(K1,N) * L_SOLB_XNEG(I1,O1,K2,N,Q)
     &                   + MCON(K2,N) * L_SOLB_XNEG(I1,O1,K1,N,Q)

                HOM1CR =   ( NXR1 + LLXR1 ) *   T_UTDN_EIGEN(K1,UT)
     &                   - ( NXR2 + LLXR2 ) *   T_UTDN_EIGEN(K2,UT)
                HOM2CR =             LXR1   * L_T_UTDN_EIGEN(K1,UT,Q)
     &                             - LXR2   * L_T_UTDN_EIGEN(K2,UT,Q)
                HOM3CR =   ( PXR1 + MLXR1 ) *   T_UTUP_EIGEN(K1,UT)
     &                   - ( PXR2 + MLXR2 ) *   T_UTUP_EIGEN(K2,UT)
                HOM4CR =             MXR1   * L_T_UTUP_EIGEN(K1,UT,Q)
     &                             - MXR2   * L_T_UTUP_EIGEN(K2,UT,Q)

                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR + HOM3CR + HOM4CR

              ENDDO

C  real part

              SHOM = SHOM_R + SHOM_CR
              QATMOSWF_F(Q,UTA,I,O1) = FMULT * SHOM

C  Finish Q, I and O1 loops

            ENDDO
          ENDDO
        ENDDO

C  Solution for N  below/above the layer NV that varies

      ELSE IF ( NV.NE.N .AND. NV.NE.0 ) THEN

C  stream/stokes directions

        DO I = 1, NSTREAMS
          I1 = I + NSTREAMS
          DO O1 = 1, NSTOKES

C  Parameter loop

            DO Q = 1, NV_PARAMETERS

C  real homogeneous solutions

              SHOM_R = ZERO
              DO K = 1, K_REAL(N)
                NXR  = NCON(K,N,Q) *   SOLA_XPOS(I1,O1,K,N)
                PXR  = PCON(K,N,Q) *   SOLB_XNEG(I1,O1,K,N)
                HOM1 = NXR * T_UTDN_EIGEN(K,UT)
                HOM2 = PXR * T_UTUP_EIGEN(K,UT)
                SHOM_R = SHOM_R + HOM1 + HOM2
              ENDDO

C  complex homogeneous solutions

              SHOM_CR = ZERO
              KO1 = K_REAL(N) + 1
              DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1
                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I1,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I1,O1,K2,N)
                NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I1,O1,K2,N)
     &                  + NCON(K2,N,Q) *   SOLA_XPOS(I1,O1,K1,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
                PXR2  =   PCON(K1,N,Q) *   SOLB_XNEG(I1,O1,K2,N)
     &                  + PCON(K2,N,Q) *   SOLB_XNEG(I1,O1,K1,N)
                HOM1CR =   NXR1  * T_UTDN_EIGEN(K1,UT)
     &                   - NXR2  * T_UTDN_EIGEN(K2,UT)
                HOM2CR =   PXR1  * T_UTUP_EIGEN(K1,UT)
     &                   - PXR2  * T_UTUP_EIGEN(K2,UT)
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR
              ENDDO

C  real part

              SHOM = SHOM_R + SHOM_CR
              QATMOSWF_F(Q,UTA,I,O1) = FMULT * SHOM

C  Finish Q, I and O1 loops

            ENDDO
          ENDDO
        ENDDO

C  end variability clause

      ENDIF

C  Add the linearized thermal solution  (if flagged)
C    ---Only present if N = NV, or NV = 0 (column linearization)
C   THIS is the solution with scattering

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        O1 = 1
        IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
          DO I = 1, NSTREAMS
            I1 = I + NSTREAMS
            DO Q = 1, NV_PARAMETERS
              SPAR = L_UT_T_PARTIC(I1,UT,Q)
              QATMOSWF_F(Q,UTA,I,O1) =
     &            QATMOSWF_F(Q,UTA,I,O1) + FMULT * SPAR
            ENDDO
          ENDDO
        ENDIF
      ENDIF

C  Finished if no solar terms

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Add Linearized Classical beam solution
C  Green function solution is still a Placeholder....!
C    solutions exist only for N = NV or N > NV or NV = 0

      IF ( DO_CLASSICAL_SOLUTION ) THEN
        IF ( N.GE.NV .OR. NV.EQ.0 ) THEN
          DO I = 1, NSTREAMS
            I1 = I + NSTREAMS
            DO O1 = 1, NSTOKES
              DO Q = 1, NV_PARAMETERS
                SPAR = L_WUPPER(I1,O1,N,Q) *   T_UTDN_MUBAR(UT,IB) +
     &                   WUPPER(I1,O1,N)   * L_T_UTDN_MUBAR(UT,NV,IB,Q)
                QATMOSWF_F(Q,UTA,I,O1) =
     &            QATMOSWF_F(Q,UTA,I,O1) + FMULT * SPAR
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ELSE
C                P L A C E H O L D E R
      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADATMOSWF_OFFGRID_DN
     &     ( IB, UTA, UT, N, NV, NV_PARAMETERS,
     &       DO_INCLUDE_THERMEMISS, FLUX_MULTIPLIER, QATMOSWF_F )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_THERMALSUP.VARS'

C  include files of linearized setup/solution/multiplier variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'
      INCLUDE '../includes/VLIDORT_L_THERMALSUP.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          NV, NV_PARAMETERS
      INTEGER          IB, UTA, UT, N

      DOUBLE PRECISION FLUX_MULTIPLIER
      LOGICAL          DO_INCLUDE_THERMEMISS

C  output

      DOUBLE PRECISION QATMOSWF_F
     &     ( MAX_ATMOSWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          I, Q, O1, K, KO1, K0, K1, K2, LAY
      DOUBLE PRECISION SPAR, SHOM_R, SHOM_CR, SHOM
      DOUBLE PRECISION HOM1, HOM2, HOM1CR, HOM2CR, HOM3CR, HOM4CR
      DOUBLE PRECISION NXR, PXR, NXR1, NXR2, PXR1, PXR2
      DOUBLE PRECISION LXR, MXR, LXR1, MXR1, LXR2, MXR2
      DOUBLE PRECISION LLXR, MLXR, LLXR1, MLXR1, LLXR2, MLXR2
      DOUBLE PRECISION TPROP, THELP, L_TPROP, L_THELP, FMULT

C  Short hand

      FMULT = FLUX_MULTIPLIER

C  Thermal Transmittance only
c  --------------------------

      IF ( DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          DO Q = 1, NV_PARAMETERS
            L_THELP = ZERO
            THELP   = ZERO
            DO LAY = 1, N-1
              L_THELP = L_THELP *   T_DELT_DISORDS(I,LAY)
              IF ( LAY.EQ.NV .OR. NV.EQ.0 ) THEN
                L_TPROP = L_T_WLOWER(I,LAY,Q) / QUAD_STREAMS(I)
                L_THELP = L_THELP + L_TPROP
     &                    + THELP * L_T_DELT_DISORDS(I,LAY,Q)
              ENDIF
              TPROP = T_WLOWER(I,LAY) / QUAD_STREAMS(I)
              THELP = THELP * T_DELT_DISORDS(I,LAY) + TPROP
            ENDDO
            L_THELP = L_THELP * T_DISORDS_UTDN(I,UT)
            IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
              L_TPROP = L_UT_T_PARTIC(I,UT,Q) / QUAD_STREAMS(I)
              L_THELP = L_THELP + L_TPROP
     &                  + THELP * L_T_DISORDS_UTDN(I,UT,Q)
            ENDIF
            QATMOSWF_F(Q,UTA,I,O1) = FMULT * L_THELP
          ENDDO
        ENDDO
        RETURN
      ENDIF

C  For those optical depths at off-grid levels
C  ###########################################

C  Homogeneous
C  -----------

C  solution for N being the varying layer NV

      IF ( N .EQ. NV .OR. NV.EQ.0 ) THEN

C  stream and Stokes directions

        DO I = 1, NSTREAMS
          DO O1 = 1, NSTOKES

C  Parameter loop

            DO Q = 1, NV_PARAMETERS

C  real homogeneous solutions

              SHOM_R = ZERO
              DO K = 1, K_REAL(N)
                LXR  = LCON(K,N)   *   SOLA_XPOS(I,O1,K,N)
                MXR  = MCON(K,N)   *   SOLB_XNEG(I,O1,K,N)
                LLXR = LCON(K,N)   * L_SOLA_XPOS(I,O1,K,N,Q)
                MLXR = MCON(K,N)   * L_SOLB_XNEG(I,O1,K,N,Q)
                NXR  = NCON(K,N,Q) *   SOLA_XPOS(I,O1,K,N)
                PXR  = PCON(K,N,Q) *   SOLB_XNEG(I,O1,K,N)
                HOM1 = ( NXR + LLXR ) *   T_UTDN_EIGEN(K,UT)
     &                       +  LXR   * L_T_UTDN_EIGEN(K,UT,Q)
                HOM2 = ( PXR + MLXR ) *   T_UTUP_EIGEN(K,UT)
     &                       +  MXR   * L_T_UTUP_EIGEN(K,UT,Q)
                SHOM_R = SHOM_R + HOM1 + HOM2
              ENDDO

C  complex homogeneous solutions

              SHOM_CR = ZERO
              KO1 = K_REAL(N) + 1
              DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1

                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K2,N)
                NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K2,N)
     &                  + NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K1,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K2,N)
                PXR2  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K2,N)
     &                  + PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K1,N)

                LXR1  =   LCON(K1,N) *   SOLA_XPOS(I,O1,K1,N)
     &                  - LCON(K2,N) *   SOLA_XPOS(I,O1,K2,N)
                LXR2  =   LCON(K1,N) *   SOLA_XPOS(I,O1,K2,N)
     &                  + LCON(K2,N) *   SOLA_XPOS(I,O1,K1,N)
                MXR1  =   MCON(K1,N) *   SOLB_XNEG(I,O1,K1,N)
     &                  - MCON(K2,N) *   SOLB_XNEG(I,O1,K2,N)
                MXR2  =   MCON(K1,N) *   SOLB_XNEG(I,O1,K2,N)
     &                  + MCON(K2,N) *   SOLB_XNEG(I,O1,K1,N)

                LLXR1  =   LCON(K1,N) * L_SOLA_XPOS(I,O1,K1,N,Q)
     &                   - LCON(K2,N) * L_SOLA_XPOS(I,O1,K2,N,Q)
                LLXR2  =   LCON(K1,N) * L_SOLA_XPOS(I,O1,K2,N,Q)
     &                   + LCON(K2,N) * L_SOLA_XPOS(I,O1,K1,N,Q)
                MLXR1  =   MCON(K1,N) * L_SOLB_XNEG(I,O1,K1,N,Q)
     &                   - MCON(K2,N) * L_SOLB_XNEG(I,O1,K2,N,Q)
                MLXR2  =   MCON(K1,N) * L_SOLB_XNEG(I,O1,K2,N,Q)
     &                   + MCON(K2,N) * L_SOLB_XNEG(I,O1,K1,N,Q)

                HOM1CR =   ( NXR1 + LLXR1 ) *   T_UTDN_EIGEN(K1,UT)
     &                   - ( NXR2 + LLXR2 ) *   T_UTDN_EIGEN(K2,UT)
                HOM2CR =             LXR1   * L_T_UTDN_EIGEN(K1,UT,Q)
     &                             - LXR2   * L_T_UTDN_EIGEN(K2,UT,Q)
                HOM3CR =   ( PXR1 + MLXR1 ) *   T_UTUP_EIGEN(K1,UT)
     &                   - ( PXR2 + MLXR2 ) *   T_UTUP_EIGEN(K2,UT)
                HOM4CR =             MXR1   * L_T_UTUP_EIGEN(K1,UT,Q)
     &                             - MXR2   * L_T_UTUP_EIGEN(K2,UT,Q)

                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR + HOM3CR + HOM4CR
              ENDDO

C  real part

              SHOM = SHOM_R + SHOM_CR
              QATMOSWF_F(Q,UTA,I,O1) = FMULT * SHOM

C  Finish Q, I and O1 loops

            ENDDO
          ENDDO
        ENDDO

C  Solution for N  below/above the layer NV that varies

      ELSE IF ( NV.NE.N .AND. NV.NE.0 ) THEN

C  stream/stokes directions

        DO I = 1, NSTREAMS
          DO O1 = 1, NSTOKES

C  Parameter loop

            DO Q = 1, NV_PARAMETERS

C  real homogeneous solutions

              SHOM_R = ZERO
              DO K = 1, K_REAL(N)
                NXR  = NCON(K,N,Q) *   SOLA_XPOS(I,O1,K,N)
                PXR  = PCON(K,N,Q) *   SOLB_XNEG(I,O1,K,N)
                HOM1 = NXR * T_UTDN_EIGEN(K,UT)
                HOM2 = PXR * T_UTUP_EIGEN(K,UT)
                SHOM_R = SHOM_R + HOM1 + HOM2
              ENDDO

C  complex homogeneous solutions

              SHOM_CR = ZERO
              KO1 = K_REAL(N) + 1
              DO K = 1, K_COMPLEX(N)
                K0 = 2 * K - 2
                K1 = KO1 + K0
                K2 = K1  + 1
                NXR1  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K1,N)
     &                  - NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K2,N)
                NXR2  =   NCON(K1,N,Q) *   SOLA_XPOS(I,O1,K2,N)
     &                  + NCON(K2,N,Q) *   SOLA_XPOS(I,O1,K1,N)
                PXR1  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K1,N)
     &                  - PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K2,N)
                PXR2  =   PCON(K1,N,Q) *   SOLB_XNEG(I,O1,K2,N)
     &                  + PCON(K2,N,Q) *   SOLB_XNEG(I,O1,K1,N)
                HOM1CR =   NXR1  * T_UTDN_EIGEN(K1,UT)
     &                   - NXR2  * T_UTDN_EIGEN(K2,UT)
                HOM2CR =   PXR1  * T_UTUP_EIGEN(K1,UT)
     &                   - PXR2  * T_UTUP_EIGEN(K2,UT)
                SHOM_CR = SHOM_CR + HOM1CR + HOM2CR
              ENDDO

C  real part

              SHOM = SHOM_R + SHOM_CR
              QATMOSWF_F(Q,UTA,I,O1) = FMULT * SHOM

C  Finish Q, I and O1 loops

            ENDDO
          ENDDO
        ENDDO

C  end variability clause

      ENDIF

C  Add the linearized thermal solution  (if flagged)
C    ---Only present if N = NV, or NV = 0
C   THIS IS THE SOLUTION with scattering

      IF ( DO_INCLUDE_THERMEMISS ) THEN
        O1 = 1
        IF ( N.EQ.NV .OR. NV.EQ.0 ) THEN
          DO I = 1, NSTREAMS
            DO Q = 1, NV_PARAMETERS
              SPAR = L_UT_T_PARTIC(I,UT,Q)
              QATMOSWF_F(Q,UTA,I,O1) =
     &           QATMOSWF_F(Q,UTA,I,O1) + FMULT * SPAR
            ENDDO
          ENDDO
        ENDIF
      ENDIF

C  Finished if no solar terms

      IF ( .NOT. DO_SOLAR_SOURCES ) RETURN

C  Add Linearized Classical beam solution
C  Green function solution is still a Placeholder....!
C    solutions exist only for N = NV or N > NV or NV = 0

      IF ( DO_CLASSICAL_SOLUTION ) THEN
        IF ( N.GE.NV .OR. NV.EQ.0 ) THEN
          DO I = 1, NSTREAMS
            DO O1 = 1, NSTOKES
              DO Q = 1, NV_PARAMETERS
                SPAR = L_WUPPER(I,O1,N,Q) *   T_UTDN_MUBAR(UT,IB) +
     &                   WUPPER(I,O1,N)   * L_T_UTDN_MUBAR(UT,NV,IB,Q)
                QATMOSWF_F(Q,UTA,I,O1) =
     &            QATMOSWF_F(Q,UTA,I,O1) + FMULT * SPAR
              ENDDO
            ENDDO
          ENDDO
        ENDIF
      ELSE
C                P L A C E H O L D E R
      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE VLIDORT_LS_INTEGRATED_OUTPUT
     I  ( DO_INCLUDE_MVOUTPUT,
     I    FLUX_MULTIPLIER, IBEAM, WF_INDEX,
     I    LS_BOA_THTONLY_SOURCE )

C  Quadrature output at offgrid or ongrid optical depths
C  ( Required if mean-value calculations are to be done)
C    DO_INCLUDE_MVOUTPUT = .TRUE. only for Fourier = 0 )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include file of setup variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'

C  include file of linearized setupr variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'

C  include file of result variables (module output stored here)

      INCLUDE '../includes/VLIDORT_L_RESULTS.VARS'

C  Subroutine arguments
C  --------------------

      LOGICAL          DO_INCLUDE_MVOUTPUT
      INTEGER          IBEAM, WF_INDEX
      DOUBLE PRECISION FLUX_MULTIPLIER

      DOUBLE PRECISION LS_BOA_THTONLY_SOURCE(MAXSTREAMS)

C  local variables
C  ---------------

C  Local qudrature output (for debug)

      DOUBLE PRECISION QSURFACEWF_F
     &     ( MAX_SURFACEWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  Help variables

      INTEGER          I, IDIR, WDIR, UTA, UT, N, NLEVEL, O1, QW
      DOUBLE PRECISION SMI, SFX

C  Index

      QW = WF_INDEX

C  direction loop

      DO IDIR = 1, N_DIRECTIONS
        WDIR = WHICH_DIRECTIONS(IDIR)

C  Upwelling Jacobian output at Quadrature angles

        IF ( WDIR .EQ. UPIDX ) THEN
          DO UTA = 1, N_USER_LEVELS
            NLEVEL = UTAU_LEVEL_MASK_UP(UTA)
            IF ( PARTLAYERS_OUTFLAG(UTA) ) THEN
              UT = PARTLAYERS_OUTINDEX(UTA)
              N  = PARTLAYERS_LAYERIDX(UT)
              CALL QUADSURFACEWF_OFFGRID_UP
     &          ( UTA, UT, N, QW, FLUX_MULTIPLIER,
     &            LS_BOA_THTONLY_SOURCE, QSURFACEWF_F )
            ELSE
              CALL QUADSURFACEWF_LEVEL_UP
     &          ( UTA, NLEVEL, QW, FLUX_MULTIPLIER,
     &            LS_BOA_THTONLY_SOURCE, QSURFACEWF_F )
            ENDIF
          ENDDO
        ENDIF

C  Downwelling Jacobian output at Quadrature angles

        IF ( WDIR .EQ. DNIDX ) THEN
          DO UTA = 1, N_USER_LEVELS
            NLEVEL = UTAU_LEVEL_MASK_DN(UTA)
            IF ( PARTLAYERS_OUTFLAG(UTA) ) THEN
              UT = PARTLAYERS_OUTINDEX(UTA)
              N  = PARTLAYERS_LAYERIDX(UT)
              CALL QUADSURFACEWF_OFFGRID_DN
     &          ( UTA, UT, N, QW, FLUX_MULTIPLIER,
     &            QSURFACEWF_F )
            ELSE
              CALL QUADSURFACEWF_LEVEL_DN
     &          ( UTA, NLEVEL, QW, FLUX_MULTIPLIER,
     &            QSURFACEWF_F )
            ENDIF
          ENDDO
        ENDIF

C  Mean Intensity and Flux  output (diffuse term only)

        IF ( DO_INCLUDE_MVOUTPUT ) THEN
          DO UTA = 1, N_USER_LEVELS
            DO O1 = 1, NSTOKES
              SMI = ZERO
              SFX = ZERO
              DO I = 1, NSTREAMS
                SMI = SMI + QUAD_WEIGHTS(I) * QSURFACEWF_F(QW,UTA,I,O1)
                SFX = SFX + QUAD_STRMWTS(I) * QSURFACEWF_F(QW,UTA,I,O1)
              ENDDO
              MINT_SURFACEWF(QW,UTA,IBEAM,O1,WDIR) = SMI * HALF
              FLUX_SURFACEWF(QW,UTA,IBEAM,O1,WDIR) = SFX * PI2
            ENDDO
          ENDDO
        ENDIF

C  End directions loop

      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADSURFACEWF_LEVEL_UP
     &      ( UTA, NL, QW, FLUX_MULTIPLIER,
     &        LS_BOA_THTONLY_SOURCE, QSURFACEWF_F )

C  Upwelling weighting function Fourier components at level boundary NL
C  Quadrature angles only

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'

C  include files of linearized setup and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          UTA, NL, QW
      DOUBLE PRECISION FLUX_MULTIPLIER
      DOUBLE PRECISION LS_BOA_THTONLY_SOURCE(MAXSTREAMS)

C  output

      DOUBLE PRECISION QSURFACEWF_F
     &     ( MAX_SURFACEWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          N, I, I1, O1, K, KO1, K0, K1, K2, LAY
      DOUBLE PRECISION SHOM_R, SHOM_CR, H1, H2, THELP
      DOUBLE PRECISION NXR, NXR1, NXR2, PXR, PXR1, PXR2

C  This depends on the level mask - if this is 0 to NLAYERS - 1, then we are
C  looking at the perturbation field at the top of these layers. The
C  case where the level mask = NLAYERS is the upwelling perturbed fields
C  at the bottom of the atmosphere (treated separately).

      N = NL + 1

C  For the lowest level
!  ====================

C  Thermal transmittance-only solution

      IF ( NL.EQ.NLAYERS .and. DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          THELP = LS_BOA_THTONLY_SOURCE(I)
          QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER * THELP
        ENDDO
        RETURN
      ENDIF

C  Scattering solutions
C  --------------------

      IF ( NL .EQ. NLAYERS ) THEN

c  Offset

        KO1 = K_REAL(NL) + 1

C  Stokes and streams loops

        DO I = 1, NSTREAMS
          I1 = I + NSTREAMS
          DO O1 = 1, NSTOKES

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(NL)
              NXR = NCON_ALB(K,NL) * SOLA_XPOS(I1,O1,K,NL)
              PXR = PCON_ALB(K,NL) * SOLB_XNEG(I1,O1,K,NL)
              SHOM_R = SHOM_R + NXR*T_DELT_EIGEN(K,NL) + PXR
            ENDDO

C  Complex nomoegeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(NL)
             K0 = 2 * K - 2
             K1 = KO1 + K0
             K2 = K1  + 1
             NXR1 =   NCON_ALB(K1,NL) * SOLA_XPOS(I1,O1,K1,NL)
     &              - NCON_ALB(K2,NL) * SOLA_XPOS(I1,O1,K2,NL)
             NXR2 =   NCON_ALB(K1,NL) * SOLA_XPOS(I1,O1,K2,NL)
     &              + NCON_ALB(K2,NL) * SOLA_XPOS(I1,O1,K1,NL)
             PXR1 =   PCON_ALB(K1,NL) * SOLB_XNEG(I1,O1,K1,NL)
     &              - PCON_ALB(K2,NL) * SOLB_XNEG(I1,O1,K2,NL)
             H1 =   NXR1 *  * T_DELT_EIGEN(K1,NL)
     &            - NXR2 *  * T_DELT_EIGEN(K2,NL)
             H2 =  PXR1
             SHOM_CR = SHOM_CR + H1 + H2
            ENDDO

C  collect solution

            QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER*(SHOM_R+SHOM_CR)

C  Finish loops

          ENDDO
        ENDDO

      ENDIF

C  For other levels in the atmosphere
C  ==================================

C  Thermal transmittance-only solution

      IF ( NL.NE.NLAYERS .and. DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          THELP = LS_BOA_THTONLY_SOURCE(I)
          DO LAY = NLAYERS, N, -1
            THELP = THELP*T_DELT_DISORDS(I,LAY)
          ENDDO
          QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER * THELP
        ENDDO
        RETURN
      ENDIF

C  Scattering solutions
C  --------------------

      IF ( NL .NE. NLAYERS ) THEN

c  Offset

        KO1 = K_REAL(N) + 1

C  Stokes and streams loops

        DO I = 1, NSTREAMS
          I1 = I + NSTREAMS
          DO O1 = 1, NSTOKES

C  Real homogeneous solutions

             SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              NXR = NCON_ALB(K,N) * SOLA_XPOS(I1,O1,K,N)
              PXR = PCON_ALB(K,N) * SOLB_XNEG(I1,O1,K,N)
              SHOM_R = SHOM_R + PXR*T_DELT_EIGEN(K,N) + NXR
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
             K0 = 2 * K - 2
             K1 = KO1 + K0
             K2 = K1  + 1
             NXR1 =   NCON_ALB(K1,N) * SOLA_XPOS(I1,O1,K1,N)
     &              - NCON_ALB(K2,N) * SOLA_XPOS(I1,O1,K2,N)
             PXR1 =   PCON_ALB(K1,N) * SOLB_XNEG(I1,O1,K1,N)
     &              - PCON_ALB(K2,N) * SOLB_XNEG(I1,O1,K2,N)
             PXR2 =   PCON_ALB(K1,N) * SOLB_XNEG(I1,O1,K2,N)
     &              + PCON_ALB(K2,N) * SOLB_XNEG(I1,O1,K1,N)
             H1 =   PXR1 *  * T_DELT_EIGEN(K1,N)
     &            - PXR2 *  * T_DELT_EIGEN(K2,N)
             H2 =  NXR1
             SHOM_CR = SHOM_CR + H1 + H2
            ENDDO

C  collect solution

           QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER*(SHOM_R+SHOM_CR)

C  Finish loops

          ENDDO
        ENDDO

      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADSURFACEWF_LEVEL_DN
     &      ( UTA, NL, QW, FLUX_MULTIPLIER,
     &        QSURFACEWF_F )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'

C  include files of linearized setup and solution variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          UTA, NL, QW
      DOUBLE PRECISION FLUX_MULTIPLIER

C  output

      DOUBLE PRECISION QSURFACEWF_F
     &     ( MAX_SURFACEWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          N, I, O1, K, KO1, K0, K1, K2
      DOUBLE PRECISION SHOM_R, SHOM_CR, H1, H2
      DOUBLE PRECISION NXR, NXR1, NXR2, PXR, PXR1

      N = NL

C  Zero level = TOA no solutions
C  =============================

C  Downwelling weighting function at TOA ( or N = 0 ) is zero

      IF ( NL .EQ. 0 ) THEN
        DO I = 1, NSTREAMS
          DO O1 = 1, NSTOKES
            QSURFACEWF_F(QW,UTA,I,O1) = ZERO
          ENDDO
        ENDDO
        RETURN
      ENDIF

C  For other levels in the atmosphere
C  ==================================

      IF ( NL .NE. 0 .and. DO_THERMAL_TRANSONLY) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          QSURFACEWF_F(QW,UTA,I,O1) = ZERO
        ENDDO
        RETURN
      endif

C  Scattering solutions
C  --------------------

      IF ( NL .NE. 0 ) THEN

c  Offset

        KO1 = K_REAL(N) + 1

C  Stokes and streams loops

        DO I = 1, NSTREAMS
          DO O1 = 1, NSTOKES

C  Real homogeneous solutions

            SHOM_R = ZERO
            DO K = 1, K_REAL(N)
              NXR = NCON_ALB(K,N) * SOLA_XPOS(I,O1,K,N)
              PXR = PCON_ALB(K,N) * SOLB_XNEG(I,O1,K,N)
              SHOM_R = SHOM_R + NXR*T_DELT_EIGEN(K,N) + PXR
            ENDDO

C  Complex homogeneous solutions

            SHOM_CR = ZERO
            DO K = 1, K_COMPLEX(N)
             K0 = 2 * K - 2
             K1 = KO1 + K0
             K2 = K1  + 1
             NXR1 =   NCON_ALB(K1,N) * SOLA_XPOS(I,O1,K1,N)
     &              - NCON_ALB(K2,N) * SOLA_XPOS(I,O1,K2,N)
             NXR2 =   NCON_ALB(K1,N) * SOLA_XPOS(I,O1,K2,N)
     &              + NCON_ALB(K2,N) * SOLA_XPOS(I,O1,K1,N)
             PXR1 =   PCON_ALB(K1,N) * SOLB_XNEG(I,O1,K1,N)
     &              - PCON_ALB(K2,N) * SOLB_XNEG(I,O1,K2,N)
             H1 =   NXR1 *  * T_DELT_EIGEN(K1,N)
     &            - NXR2 *  * T_DELT_EIGEN(K2,N)
             H2 =  PXR1
             SHOM_CR = SHOM_CR + H1 + H2
            ENDDO

C  collect solution

            QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER*(SHOM_R+SHOM_CR)

C  Finish loops

          ENDDO
        ENDDO
      ENDIF

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADSURFACEWF_OFFGRID_UP
     &      ( UTA, UT, N, QW, FLUX_MULTIPLIER,
     &        LS_BOA_THTONLY_SOURCE, QSURFACEWF_F )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'

C  include files of linearized setup/solution/multiplier variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          UTA, UT, N, QW
      DOUBLE PRECISION FLUX_MULTIPLIER
      DOUBLE PRECISION LS_BOA_THTONLY_SOURCE(MAXSTREAMS)

C  output

      DOUBLE PRECISION QSURFACEWF_F
     &     ( MAX_SURFACEWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          I, I1, O1, K, KO1, K0, K1, K2, LAY
      DOUBLE PRECISION SHOM_R, SHOM_CR, H1, H2, THELP
      DOUBLE PRECISION NXR, NXR1, NXR2, PXR, PXR1, PXR2

C  For thermal transmittance-only
C  ------------------------------

      IF ( DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          THELP = LS_BOA_THTONLY_SOURCE(I)
          DO LAY = NLAYERS, N+1, -1
            THELP = THELP*T_DELT_DISORDS(I,LAY)
          ENDDO
          THELP = THELP*T_DISORDS_UTUP(I,UT)
          QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER * THELP
        ENDDO
        RETURN
      ENDIF

C  For those optical depths at off-grid levels
C  -------------------------------------------

C  Offset

      KO1 = K_REAL(N) + 1

C  stream directions

      DO I = 1, NSTREAMS
        I1 = I + NSTREAMS
        DO O1 = 1, NSTOKES

C  real homogeneous solutions

          SHOM_R = ZERO
          DO K = 1, K_REAL(N)
            NXR = NCON_ALB(K,N) * SOLA_XPOS(I1,O1,K,N)
            PXR = PCON_ALB(K,N) * SOLB_XNEG(I1,O1,K,N)
            SHOM_R = SHOM_R + NXR * T_UTDN_EIGEN(K,UT)
     &                      + PXR * T_UTUP_EIGEN(K,UT)
            SHOM_R = SHOM_R + H1 + H2
          ENDDO

C  complex homogeneous solutions

          SHOM_CR = ZERO
          DO K = 1, K_COMPLEX(N)
            K0 = 2 * K - 2
            K1 = KO1 + K0
            K2 = K1  + 1
            NXR1 =   NCON_ALB(K1,N) * SOLA_XPOS(I1,O1,K1,N)
     &             - NCON_ALB(K2,N) * SOLA_XPOS(I1,O1,K2,N)
            NXR2 =   NCON_ALB(K1,N) * SOLA_XPOS(I1,O1,K2,N)
     &             + NCON_ALB(K2,N) * SOLA_XPOS(I1,O1,K1,N)
            PXR1 =   PCON_ALB(K1,N) * SOLB_XNEG(I1,O1,K1,N)
     &             - PCON_ALB(K2,N) * SOLB_XNEG(I1,O1,K2,N)
            PXR2 =   PCON_ALB(K1,N) * SOLB_XNEG(I1,O1,K2,N)
     &             + PCON_ALB(K2,N) * SOLB_XNEG(I1,O1,K1,N)
            H1 =   NXR1 *  * T_UTDN_EIGEN(K1,N)
     &           - NXR2 *  * T_UTDN_EIGEN(K2,N)
            H2 =   PXR1 *  * T_UTUP_EIGEN(K1,N)
     &           - PXR2 *  * T_UTUP_EIGEN(K2,N)
            SHOM_CR = SHOM_CR + H1 + H2
          ENDDO

C  set result

          QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER*(SHOM_R+SHOM_CR)

C  end O1 and I loops

        ENDDO
      ENDDO

C  Finish

      RETURN
      END

C

      SUBROUTINE QUADSURFACEWF_OFFGRID_DN
     &      ( UTA, UT, N, QW, FLUX_MULTIPLIER,
     &        QSURFACEWF_F )

C  include files
C  -------------

C  include file of dimensions and numbers

      INCLUDE '../includes/VLIDORT.PARS'

C  include files of input and bookkeeping variables

      INCLUDE '../includes/VLIDORT_INPUTS.VARS'
      INCLUDE '../includes/VLIDORT_BOOKKEEP.VARS'

C  include files of setup, solution and multiplier variables (input)

      INCLUDE '../includes/VLIDORT_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_MULTIPLIERS.VARS'

C  include files of linearized setup/solution/multiplier variables (input)

      INCLUDE '../includes/VLIDORT_L_SETUPS.VARS'
      INCLUDE '../includes/VLIDORT_L_SOLUTION.VARS'
      INCLUDE '../includes/VLIDORT_L_MULTIPLIERS.VARS'

C  Subroutine arguments
C  --------------------

C  Inputs

      INTEGER          UTA, UT, N, QW
      DOUBLE PRECISION FLUX_MULTIPLIER

C  output

      DOUBLE PRECISION QSURFACEWF_F
     &     ( MAX_SURFACEWFS, MAX_USER_LEVELS, MAXSTREAMS, MAXSTOKES )

C  local variables
C  ---------------

      INTEGER          I, O1, K, KO1, K0, K1, K2
      DOUBLE PRECISION SHOM_R, SHOM_CR, H1, H2
      DOUBLE PRECISION NXR, NXR1, NXR2, PXR, PXR1, PXR2

C  For thermal transmittance-only, no contribution
C  -----------------------------------------------

      IF ( DO_THERMAL_TRANSONLY ) THEN
        O1 = 1
        DO I = 1, NSTREAMS
          QSURFACEWF_F(QW,UTA,I,O1) = ZERO
        ENDDO
        RETURN
      ENDIF
C  For those optical depths at off-grid levels
C  -------------------------------------------

C  Offset

      KO1 = K_REAL(N) + 1

C  stream directions

      DO I = 1, NSTREAMS
        DO O1 = 1, NSTOKES

C  real homogeneous solutions

          SHOM_R = ZERO
          DO K = 1, K_REAL(N)
            NXR = NCON_ALB(K,N) * SOLA_XPOS(I,O1,K,N)
            PXR = PCON_ALB(K,N) * SOLB_XNEG(I,O1,K,N)
            SHOM_R = SHOM_R + NXR * T_UTDN_EIGEN(K,UT)
     &                      + PXR * T_UTUP_EIGEN(K,UT)
            SHOM_R = SHOM_R + H1 + H2
          ENDDO

C  complex homogeneous solutions

          SHOM_CR = ZERO
          DO K = 1, K_COMPLEX(N)
            K0 = 2 * K - 2
            K1 = KO1 + K0
            K2 = K1  + 1
            NXR1 =   NCON_ALB(K1,N) * SOLA_XPOS(I,O1,K1,N)
     &             - NCON_ALB(K2,N) * SOLA_XPOS(I,O1,K2,N)
            NXR2 =   NCON_ALB(K1,N) * SOLA_XPOS(I,O1,K2,N)
     &             + NCON_ALB(K2,N) * SOLA_XPOS(I,O1,K1,N)
            PXR1 =   PCON_ALB(K1,N) * SOLB_XNEG(I,O1,K1,N)
     &             - PCON_ALB(K2,N) * SOLB_XNEG(I,O1,K2,N)
            PXR2 =   PCON_ALB(K1,N) * SOLB_XNEG(I,O1,K2,N)
     &             + PCON_ALB(K2,N) * SOLB_XNEG(I,O1,K1,N)
            H1 =   NXR1 *  * T_UTDN_EIGEN(K1,N)
     &           - NXR2 *  * T_UTDN_EIGEN(K2,N)
            H2 =   PXR1 *  * T_UTUP_EIGEN(K1,N)
     &           - PXR2 *  * T_UTUP_EIGEN(K2,N)
            SHOM_CR = SHOM_CR + H1 + H2
          ENDDO

C  set result

          QSURFACEWF_F(QW,UTA,I,O1) = FLUX_MULTIPLIER*(SHOM_R+SHOM_CR)

C  end O1 and I loops

        ENDDO
      ENDDO

C  Finish

      RETURN
      END