OB.DAAC Logo
NASA Logo
Ocean Color Science Software

ocssw V2022
modis_surface_nc4.f95
Go to the documentation of this file.
1 module modis_surface
2 !-----------------------------------------------------------------------------------------
3 ! Module to organize functions related the surface reflectivity calculations and tables
4 ! for Aqua MODIS.
5 !
6 ! Corey Bettenhausen
7 ! Science Systems and Applications, Inc
8 ! NASA Goddard Space Flight Center
9 !
10 ! Jeremy Warner
11 ! Science Systems and Applications, Inc
12 ! NASA Goddard Space Flight Center
13 !-----------------------------------------------------------------------------------------
14  implicit none
15 
16  private
17 
18  public :: load_terrainflg_tables, load_seasonal_desert
19  public :: load_swir_coeffs
20  public :: get_swir_coeffs412, get_swir_coeffs470
21  public :: get_swir_stderr412, get_swir_stderr470
22  public :: get_swir_range
23  public :: get_brdfcorr_sr
24  public :: load_brdf, unload_brdf
25  public :: get_aot500
26  public :: terrain_flag_new, terrain_flag, sfc_elev_std
27  public :: set_limits, load_hdfler, set_limits6
28  public :: get_ler412, get_ler470, get_ler650, get_ler865
29  public :: get_modis_ler412, get_modis_ler470, get_modis_ler650, get_modis_ler865
30  public :: get_viirs_ler412, get_viirs_ler488, get_viirs_ler670
31  public :: get_viirs_modisbrdf_ler412, get_viirs_modisbrdf_ler488, get_viirs_modisbrdf_ler670
32  public :: latlon_to_index_ler
33  public :: get_geographic_zone, get_sfc_elev_std, get_background_aod! 9 January 2018 JLee
34  private :: readler5, readler2
35 
36 ! -- brdf650 = summer surface reflectivity at 650nm, used to transfer BRDF from
37 ! AERONET site to pixel location.
38 ! -- aero_sites = list of AERONET site names as listed on the AERONET website
39 ! -- aero_zones = geographical zone index of site based upon seawifs_terrainflag_*.hdf input
40 ! -- aero_types = land cover type of AERONET site based upon landcover_*.hdf input
41 ! -- aero_elev = elevation of AERONET site in meters from surface_pressure_*.hdf input
42 ! -- aero_sr* = surface reflectance of AERONET site based on surface database at 135 degrees in
43 ! winter(1), spring(2), summer(3), and fall(4).
44  real, dimension(:,:), allocatable :: brdf650
45  character(len=255), dimension(:), allocatable :: aero_sites
46  integer, dimension(:), allocatable :: aero_zones
47  integer, dimension(:), allocatable :: aero_types
48  integer, dimension(:), allocatable :: aero_elev
49  real, dimension(:,:), allocatable :: aero_sr412, aero_sr470, aero_sr650, aero_bgaod
50 
51  integer,dimension(3600,1800) :: terrain_flag_new
52  real, dimension(3600,1800) :: terrain_flag, sfc_elev_std
53  real, dimension(360,180) :: bg_aod! 9 January 2018 JLee
54 
55  integer :: lerstart(2), leredge(2), dateline
56  integer :: lerstart6(2), leredge6(2), dateline6
57  real, dimension(:,:,:,:), allocatable :: coefs650_fwd, coefs470_fwd, coefs412_fwd
58  real, dimension(:,:,:,:), allocatable :: coefs650_all, coefs470_all, coefs412_all
59 
60  real, dimension(:,:), allocatable :: gref412_all, gref412_fwd
61  real, dimension(:,:), allocatable :: gref470_all, gref470_fwd
62  real, dimension(:,:), allocatable :: gref650_all, gref650_fwd
63  real, dimension(:,:), allocatable :: gref865_all
64 
65 ! -- VIIRS, all-angle surface database
66  real, dimension(:,:), allocatable :: vgref412_all
67  real, dimension(:,:), allocatable :: vgref488_all
68  real, dimension(:,:), allocatable :: vgref670_all
69 
70 ! -- 2.2 um surface database
71  real, dimension(:,:,:), allocatable :: swir_coeffs412, swir_coeffs470
72  real, dimension(:,:), allocatable :: swir_stderr412, swir_stderr470
73  real, dimension(:,:), allocatable :: swir_min, swir_max
74 
75  real, parameter :: ndvi1_cutoff = 0.18
76  real, parameter :: ndvi2_cutoff = 0.35
77 
78  contains
79 
80 ! @TODO: should rename this to load_geozone_table or something even more descriptive.
81  integer function load_terrainflg_tables(tflg_file, season) result(status)
82 
83 ! include 'hdf.f90'
84 ! include 'dffunc.f90'
85  use netcdf
86 
87  implicit none
88 
89  character(len=255), intent(in) :: tflg_file
90  integer, intent(in) :: season
91 
92  real, dimension(:,:), allocatable :: tmptfn
93  real, dimension(:,:,:), allocatable :: tmpaod
94  integer :: i, j
95 
96  ! HDF vars
97  character(len=255) :: sds_name
98  character(len=255) :: dset_name
99  character(len=255) :: attr_name
100  character(len=255) :: group_name
101 
102  integer :: nc_id
103  integer :: dim_id
104  integer :: dset_id
105  integer :: grp_id
106  integer :: sd_id, sds_index, sds_id
107  integer, dimension(2) :: start2, stride2, edges2
108  integer, dimension(3) :: start3, stride3, edges3
109 
110  status = -1
111 
112 ! -- allocate our tmp array
113  allocate(tmptfn(3600,1800), stat=status)
114  if (status /= 0) then
115  print *, "ERROR: Unable to allocate tmp array for geo zone data: ", status
116  return
117  end if
118 
119 ! -- allocate our tmp array
120  allocate(tmpaod(360,180,4), stat=status)
121  if (status /= 0) then
122  print *, "ERROR: Unable to allocate tmp array for background aod data: ", status
123  return
124  end if
125 
126  status = nf90_open(tflg_file, nf90_nowrite, nc_id)
127  if (status /= nf90_noerr) then
128  print *, "ERROR: Failed to open deepblue lut_nc4 file: ", status
129  return
130  end if
131 
132  group_name = 'GEOZONE'
133  status = nf90_inq_ncid(nc_id, group_name, grp_id)
134  if (status /= nf90_noerr) then
135  print *, "ERROR: Failed to get ID of group "//trim(group_name)//": ", status
136  return
137  end if
138 
139  start2 = (/1,1/)
140  stride2 = (/1,1/)
141  edges2 = (/3600,1800/)
142  dset_name = 'GEOZONE_FLAG'
143  status = nf90_inq_varid(grp_id, dset_name, dset_id)
144  if (status /= nf90_noerr) then
145  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
146  return
147  end if
148  status = nf90_get_var(grp_id, dset_id, tmptfn, start=start2, &
149  stride=stride2, count=edges2)
150  if (status /= nf90_noerr) then
151  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
152  return
153  end if
154 
155  dset_name = 'ELEVATION_STDV'
156  status = nf90_inq_varid(grp_id, dset_name, dset_id)
157  if (status /= nf90_noerr) then
158  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
159  return
160  end if
161  status = nf90_get_var(grp_id, dset_id, sfc_elev_std, start=start2, &
162  stride=stride2, count=edges2)
163  if (status /= nf90_noerr) then
164  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
165  return
166  end if
167 
168  start3 = (/1,1,1/)
169  stride3 = (/1,1,1/)
170  edges3 = (/360,180,4/)
171  dset_name = 'BACKGROUND_AOD'
172  status = nf90_inq_varid(grp_id, dset_name, dset_id)
173  if (status /= nf90_noerr) then
174  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
175  return
176  end if
177  status = nf90_get_var(grp_id, dset_id, tmpaod, start=start3, &
178  stride=stride3, count=edges3)
179  if (status /= nf90_noerr) then
180  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
181  return
182  end if
183 
184  status = nf90_close(nc_id)
185  if (status /= nf90_noerr) then
186  print *, "ERROR: Failed to close lut_nc4 file: ", status
187  return
188  end if
189 
190  terrain_flag_new = int(tmptfn)
191  bg_aod(1:360,1:180) = tmpaod(1:360,1:180,season)
192  !print *, "aod test", bg_aod(1,68), tmpaod(1,68,season)
193 
194 ! -- clean up tmptfn
195  deallocate(tmptfn, stat=status)
196  if (status /= 0) then
197  print *, "ERROR: Unable to deallocate tmp array for geo zone data: ", status
198  return
199  end if
200 
201 ! -- clean up tmpaod
202  deallocate(tmpaod, stat=status)
203  if (status /= 0) then
204  print *, "ERROR: Unable to deallocate tmp array for geo zone data: ", status
205  return
206  end if
207 
208  status = 0
209  return
210  end function load_terrainflg_tables
211 
212  integer function load_seasonal_desert(file) result(status)
213 
214 ! include 'hdf.f90'
215 ! include 'dffunc.f90'
216  use netcdf
217 
218  implicit none
219 
220  character(len=255), intent(in) :: file
221 
222  real, dimension(:,:), allocatable :: tmptfn
223  integer :: i, j
224 
225  ! HDF vars
226  character(len=255) :: sds_name
227  character(len=255) :: dset_name
228  character(len=255) :: attr_name
229  character(len=255) :: group_name
230 
231  integer :: nc_id
232  integer :: dim_id
233  integer :: dset_id
234  integer :: grp_id
235  integer :: sd_id, sds_index, sds_id
236  integer, dimension(2) :: start2, stride2, edges2
237 
238  status = -1
239 
240  status = nf90_open(file, nf90_nowrite, nc_id)
241  if (status /= nf90_noerr) then
242  print *, "ERROR: Failed to open deepblue lut_nc4 file: ", status
243  return
244  end if
245 
246  group_name = 'LANDCOVER'
247  status = nf90_inq_ncid(nc_id, group_name, grp_id)
248  if (status /= nf90_noerr) then
249  print *, "ERROR: Failed to get ID of group "//trim(group_name)//": ", status
250  return
251  end if
252 
253  start2 = (/1,1/)
254  stride2 = (/1,1/)
255  edges2 = (/3600,1800/)
256  dset_name = 'DESERTS_FLAG'
257  status = nf90_inq_varid(grp_id, dset_name, dset_id)
258  if (status /= nf90_noerr) then
259  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
260  return
261  end if
262  status = nf90_get_var(grp_id, dset_id, terrain_flag, start=start2, &
263  stride=stride2, count=edges2)
264  if (status /= nf90_noerr) then
265  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
266  return
267  end if
268 
269  status = nf90_close(nc_id)
270  if (status /= nf90_noerr) then
271  print *, "ERROR: Failed to close lut_nc4 file: ", status
272  return
273  end if
274 
275  status = 0
276  return
277  end function load_seasonal_desert
278 
279 ! -- initialize the AERONET site and surface variables and load the BRDF base
280 ! -- reflectivity file into brdf650 array.
281 !-----------------------------------------------------------------------------------------
282  integer function load_brdf(brdffile) result(status)
283 
284 ! include 'hdf.f90'
285 ! include 'dffunc.f90'
286  use netcdf
287 
288  implicit none
289 
290  character(len=255), intent(in) :: brdffile
291 
292  integer, parameter :: nsites = 30
293 
294  character(len=255) :: sds_name
295  character(len=255) :: dset_name
296  character(len=255) :: attr_name
297  character(len=255) :: group_name
298 
299  integer :: nc_id
300  integer :: dim_id
301  integer :: dset_id
302  integer :: grp_id
303  integer :: sd_id, sds_index, sds_id
304  integer, dimension(2) :: start2, stride2, edges2, dims2
305 
306 ! -- assume a successful return.
307  status = 0
308 
309 ! -- allocate and fill AERONET-related arrays.
310  allocate(aero_sites(nsites), aero_zones(nsites), aero_types(nsites), aero_elev(nsites), &
311  & stat=status)
312  if (status /= 0) then
313  print *, "ERROR: Unable to allocate AERONET site info arrays: ", status
314  return
315  end if
316 
317  allocate(aero_sr412(nsites,4), aero_sr470(nsites,4), aero_sr650(nsites,4), aero_bgaod(nsites,4), stat=status)
318  if (status /= 0) then
319  print *, "ERROR: Unable to allocate AERONET SR arrays: ", status
320  return
321  end if
322 
323 ! -- aero_types = land cover type over AERONET site
324 ! -- 0. ocean
325 ! -- 1. forest
326 ! -- 2. grasslands
327 ! -- 3. croplands
328 ! -- 4. urban
329 ! -- 5. snow/ice
330 ! -- 6. barren/desert
331 
332 ! -- Banizoumbou
333  aero_sites(1) = 'Banizoumbou'
334  aero_types(1) = 2
335  aero_zones(1) = 5
336  aero_elev(1) = 250
337  aero_sr412(1,:) = (/7.08923, 7.71880, 8.48224, 6.62584/)
338  aero_sr470(1,:) = (/10.5942, 11.6695, 12.4470, 9.9028/)
339  aero_sr650(1,:) = (/28.7862, 31.9045, 31.5499, 25.0119/)
340  aero_bgaod(1,:) = (/0.15000, 0.22800, 0.26300, 0.18500/) !MODIS
341 ! aero_bgaod(1,:) = (/0.18200, 0.41348, 0.37300, 0.19649/) !MISR
342 
343 ! -- Tinga Tingana
344  aero_sites(2) = 'Tinga_Tingana'
345  aero_types(2) = 6
346  aero_zones(2) = 12
347  aero_elev(2) = 38
348  aero_sr412(2,:) = (/8.3397, 9.3348, 8.3018, 10.4549/)
349  aero_sr470(2,:) = (/11.5649, 12.8902, 11.5255, 13.5749/)
350  aero_sr650(2,:) = (/29.0277, 31.3340, 27.9479, 30.2249/)
351  aero_bgaod(2,:) = (/0.02300, 0.01900, 0.01800, 0.02100/)
352 ! aero_bgaod(2,:) = (/0.08670, 0.06223, 0.05391, 0.10703/)
353 
354 ! -- Zinder_Airport
355  aero_sites(3) = 'Zinder_Airport'
356  aero_types(3) = 2
357  aero_zones(3) = 1
358  aero_elev(3) = 456
359  aero_sr412(3,:) = (/7.59892, 8.63954, 8.38775, 6.58359/)
360  aero_sr470(3,:) = (/11.3537, 12.8399, 12.3052, 9.87239/)
361  aero_sr650(3,:) = (/26.7511, 30.1220, 27.5969, 21.1145/)
362  aero_bgaod(3,:) = (/0.15400, 0.29600, 0.30200, 0.14300/)
363 ! aero_bgaod(3,:) = (/0.15523, 0.37014, 0.35720, 0.17437/)
364 
365 ! -- Moldova
366  aero_sites(4) = 'Moldova'
367  aero_types(4) = 4
368  aero_zones(4) = 17
369  aero_elev(4) = 205
370  aero_sr412(4,:) = (/-999.000, 6.10670, 5.23876, 5.76111/)
371  aero_sr470(4,:) = (/-999.000, 7.08618, 6.13133, 6.63834/)
372  aero_sr650(4,:) = (/-999.000, 8.11562, 7.51764, 7.96273/)
373  aero_bgaod(4,:) = (/0.01900, 0.05900, 0.07700, 0.04300/)
374 ! aero_bgaod(4,:) = (/0.07450, 0.12211, 0.12758, 0.07907/)
375 
376 ! -- Beijing
377  aero_sites(5) = 'Beijing'
378  aero_types(5) = 4
379  aero_zones(5) = 16
380  aero_elev(5) = 92
381  aero_sr412(5,:) = (/5.04678, 6.91650, 6.04189, 5.75009/)
382  aero_sr470(5,:) = (/7.59624, 8.45864, 7.31190, 7.05383/)
383  aero_sr650(5,:) = (/11.7573, 11.3573, 9.2663, 8.54484/)
384  aero_bgaod(5,:) = (/0.13800, 0.18100, 0.14400, 0.11400/)
385 ! aero_bgaod(5,:) = (/0.12670, 0.19608, 0.20208, 0.11582/)
386 
387 ! -- Kanpur, India except for urban areas and Thar Desert
388  aero_sites(6) = 'Kanpur'
389  aero_types(6) = 3
390  aero_zones(6) = 15
391  aero_elev(6) = 123
392 ! use fall BRDF for summer, 26 January 2018 JLee, TEST
393  aero_sr412(6,:) = (/8.76996,6.24308,8.49987,7.49987/)
394  aero_sr470(6,:) = (/6.26996,5.74308,7.99987,5.99987/)
395  aero_sr650(6,:) = (/10.25542,10.1785,11.75790,10.75790/)
396  aero_bgaod(6,:) = (/0.27400, 0.24800, 0.27600, 0.27900/)
397 ! aero_bgaod(6,:) = (/0.31233, 0.28328, 0.44091, 0.36488/)
398 
399 ! -- Modena
400  aero_sites(7) = 'Modena'
401  aero_types(7) = 4
402  aero_zones(7) = 17
403  aero_elev(7) = 56
404  aero_sr412(7,:) = (/3.7846,5.30996,5.72852,5.69932/)
405  aero_sr470(7,:) = (/5.3279,6.31288,7.11941,6.54509/)
406  aero_sr650(7,:) = (/5.5748,9.44464,9.73280,10.1099/)
407  aero_bgaod(7,:) = (/0.02100, 0.09200, 0.09900, 0.03900/)
408 ! aero_bgaod(7,:) = (/0.06867, 0.13446, 0.15744, 0.09253/)
409 
410 ! -- Palencia
411  aero_sites(8) = 'Palencia'
412  aero_types(8) = 3
413  aero_zones(8) = 17
414  aero_elev(8) = 750
415  aero_sr412(8,:) = (/-999.000,5.03951,4.76740,-999.000/)
416  aero_sr470(8,:) = (/-999.000,6.17346,6.62762,-999.000/)
417  aero_sr650(8,:) = (/-999.000,8.70520,10.7275,-999.000/)
418  aero_bgaod(8,:) = (/0.02500, 0.04000, 0.02700, 0.03300/)
419 ! aero_bgaod(8,:) = (/0.05151, 0.09216, 0.10017, 0.06591/)
420 
421 ! -- Lecce_University
422  aero_sites(9) = 'Lecce_University'
423  aero_types(9) = 2
424  aero_zones(9) = 17
425  aero_elev(9) = 30
426  aero_sr412(9,:) = (/4.68698,4.01772,6.14852,5.86577/)
427  aero_sr470(9,:) = (/5.16447,5.68885,8.15023,6.82434/)
428  aero_sr650(9,:) = (/10.1211,10.6153,11.0301,11.3503/)
429  aero_bgaod(9,:) = (/0.05700, 0.08800, 0.06200, 0.06800/)
430 ! aero_bgaod(9,:) = (/0.06377, 0.12146, 0.13148, 0.08287/)
431 
432 ! -- Fresno_2
433 ! This controls N. America urban areas. Fresno AERONET validation is affected by
434 ! both Fresno_2 and Fresno_GZ18. Currently optimized for general urban areas,
435 ! as thinking of making separate geozone for Fresno if validation is not
436 ! acceptable at Fresno. Only baseline change would be needed for the new zone.
437  aero_sites(10) = 'Fresno_2'
438  aero_types(10) = 4
439  aero_zones(10) = 13
440  aero_elev(10) = 0.0
441  aero_sr412(10,:) = (/5.68700,4.64569,4.42003,4.78884/)
442  aero_sr470(10,:) = (/6.91660,6.96638,6.80781,6.73356/)
443  aero_sr650(10,:) = (/11.5361,12.2151,12.2892,12.6795/)
444  aero_bgaod(10,:) = (/0.05300, 0.11500, 0.08500, 0.08100/)
445 ! aero_bgaod(10,:) = (/0.08402, 0.13809, 0.14728, 0.10320/)
446 
447 ! -- Fresno (Central Valley)
448  aero_sites(11) = 'Fresno_GZ18'
449  aero_types(11) = 2
450  aero_zones(11) = 18
451  aero_elev(11) = 0.0
452  aero_sr412(11,:) = (/6.18700,5.14569,4.92003,5.28884/)
453  aero_sr470(11,:) = (/7.41660,7.46638,7.30781,7.23356/)
454  aero_sr650(11,:) = (/11.5361,12.2151,12.2892,12.6795/)
455  aero_bgaod(11,:) = (/0.05300, 0.11500, 0.08500, 0.08100/)
456 ! aero_bgaod(11,:) = (/0.08402, 0.13809, 0.14728, 0.10320/)
457 
458 ! -- IER_Cinzana
459  aero_sites(12) = 'IER_Cinzana'
460  aero_types(12) = 2
461  aero_zones(12) = 5
462  aero_elev(12) = 285
463  aero_sr412(12,:) = (/5.33969,6.89590,7.78313,5.45146/)
464  aero_sr470(12,:) = (/8.17876,10.2201,11.0532,7.67885/)
465  aero_sr650(12,:) = (/18.6043,21.9242,19.8147,13.6748/)
466  aero_bgaod(12,:) = (/0.16800, 0.24200, 0.12900, 0.17400/)
467 ! aero_bgaod(12,:) = (/0.14072, 0.32845, 0.29905, 0.18086/)
468 
469 ! -- Agoufou
470  aero_sites(13) = 'Agoufou'
471  aero_types(13) = 2
472  aero_zones(13) = -1 !5
473  aero_elev(13) = 305
474  aero_sr412(13,:) = (/6.33764,7.20075,7.12166,5.88014/)
475  aero_sr470(13,:) = (/10.3036,11.2734,10.7413,9.34117/)
476  aero_sr650(13,:) = (/26.6428,30.4116,27.0584,21.6639/)
477  aero_bgaod(13,:) = (/0.11800, 0.20500, 0.19900, 0.13200/)
478 ! aero_bgaod(13,:) = (/0.12562, 0.29455, 0.39775, 0.17390/)
479 
480 ! -- Saada -- leave disabled, decided not to use it. troublesome site.
481  aero_sites(14) = 'Saada'
482  aero_types(14) = 3
483  aero_zones(14) = -1 !2
484  aero_elev(14) = 420
485  aero_sr412(14,:) = (/7.30339, 5.90723, 6.37791, 6.20939/)
486  aero_sr470(14,:) = (/8.68933, 7.76850, 8.46196, 8.15088/)
487  aero_sr650(14,:) = (/14.1430, 14.5881, 16.7061, 15.5649/)
488  aero_bgaod(14,:) = (/0.08300, 0.06400, 0.08800, 0.08700/)
489 ! aero_bgaod(14,:) = (/0.03898, 0.06964, 0.08859, 0.07119/)
490 
491 ! -- Trelew (S. America)
492  aero_sites(15) = 'Trelew'
493  aero_types(15) = 6
494  aero_zones(15) = 14
495  aero_elev(15) = 15
496  aero_sr412(15,:) = (/5.29937, 5.30638, 6.01197, 5.75946/)
497  aero_sr470(15,:) = (/8.20220, 7.37385, 7.43250, 7.71553/)
498  aero_sr650(15,:) = (/14.0610, 11.7312, 11.2763, 12.9785/)
499  aero_bgaod(15,:) = (/0.02200, 0.01900, 0.01700, 0.01900/)
500 ! aero_bgaod(15,:) = (/0.06490, 0.03365, 0.03397, 0.05836/)
501 
502 ! -- Carpentras
503  aero_sites(16) = 'Carpentras'
504  aero_types(16) = 3
505  aero_zones(16) = 17
506  aero_elev(16) = 100
507  aero_sr412(16,:) = (/-999.000,4.27180,3.84850,3.60839/)
508  aero_sr470(16,:) = (/-999.000,5.77824,5.63915,5.02537/)
509  aero_sr650(16,:) = (/-999.000,9.71739,9.57229,8.67115/)
510  aero_bgaod(16,:) = (/0.01900, 0.03200, 0.03500, 0.02100/)
511 ! aero_bgaod(16,:) = (/0.03448, 0.06474, 0.05331, 0.03388/)
512 
513 ! -- 25km BRDF
514 ! aero_sr412(16,:) = (/-999.000,4.72180,4.64850,4.20839/)
515 ! aero_sr470(16,:) = (/-999.000,6.22824,6.43915,5.62537/)
516 ! aero_sr650(16,:) = (/-999.000,9.71739,9.57229,8.67115/)
517 
518 ! -- Pune, India urban areas
519  aero_sites(17) = 'Pune'
520  aero_types(17) = 4
521  aero_zones(17) = 19
522  aero_elev(17) = 559
523  aero_sr412(17,:) = (/4.49376,6.22264,4.81305,7.31305/)
524  aero_sr470(17,:) = (/5.42197,8.08891,5.49410,7.99410/)
525  aero_sr650(17,:) = (/8.40501,11.6605,6.73313,9.23313/)
526  aero_bgaod(17,:) = (/0.20400, 0.16400, 0.07500, 0.17100/)
527 ! aero_bgaod(17,:) = (/0.14888, 0.21124, 0.27165, 0.19066/)
528 
529 ! -- Evora, Spain
530  aero_sites(18) = 'Evora'
531  aero_types(18) = 3
532  aero_zones(18) = 22
533  aero_elev(18) = 293
534  aero_sr412(18,:) = (/4.95347,4.48004,4.75238,5.64016/)
535  aero_sr470(18,:) = (/5.60902,5.80674,7.54495,7.83002/)
536  aero_sr650(18,:) = (/6.80235,6.94325,13.3975,11.9871/)
537  aero_bgaod(18,:) = (/0.01900, 0.03400, 0.02600, 0.02500/)
538 ! aero_bgaod(18,:) = (/0.03544, 0.06548, 0.09886, 0.05251/)
539 
540 ! -- Blida, N. Africa
541  aero_sites(19) = 'Blida'
542  aero_types(19) = 3
543  aero_zones(19) = -1 !2
544  aero_elev(19) = 230
545  aero_sr412(19,:) = (/-999.000,5.20722,5.84409,-999.000/)
546  aero_sr470(19,:) = (/-999.000,7.35584,7.89343,-999.000/)
547  aero_sr650(19,:) = (/-999.000,11.1594,13.5330,-999.000/)
548  aero_bgaod(19,:) = (/0.04400, 0.04900, 0.07700, 0.05800/)
549 ! aero_bgaod(19,:) = (/0.07116, 0.10362, 0.15463, 0.09386/)
550 
551 ! -- Blida, N. Africa
552  aero_sites(20) = 'Blida_High'
553  aero_types(20) = 3
554  aero_zones(20) = -1 !2
555  aero_elev(20) = 600
556  aero_sr412(20,:) = (/-999.000,5.20722,5.84409,-999.000/)
557  aero_sr470(20,:) = (/-999.000,7.35584,7.89343,-999.000/)
558  aero_sr650(20,:) = (/-999.000,11.1594,13.5330,-999.000/)
559  aero_bgaod(20,:) = (/0.04400, 0.04900, 0.07700, 0.05800/)
560 ! aero_bgaod(20,:) = (/0.07116, 0.10362, 0.15463, 0.09386/)
561 
562 ! -- GZ24_Only, covers Taklimakan Desert, only AOT models are used here.
563  aero_sites(21) = 'GZ24_Only'
564  aero_types(21) = -1
565  aero_zones(21) = 24
566  aero_elev(21) = -1
567  aero_sr412(21,:) = (/-999.0,-999.0,-999.0,-999.0/) ! new from surf. coeffs.
568  aero_sr470(21,:) = (/-999.0,-999.0,-999.0,-999.0/)
569  aero_sr650(21,:) = (/-999.0,-999.0,-999.0,-999.0/)
570  aero_bgaod(21,:) = (/ -999.0, -999.0, -999.0, -999.0/)
571 ! aero_bgaod(21,:) = (/ -999.0, -999.0, -999.0, -999.0/)
572 
573 ! -- Ilorin
574  aero_sites(22) = 'Ilorin'
575  aero_types(22) = 2
576  aero_zones(22) = 26
577  aero_elev(22) = 350
578  aero_sr412(22,:) = (/4.79848, 4.13429, -999.000, -999.000/)
579  aero_sr470(22,:) = (/5.73108, 5.07124, -999.000, -999.000/)
580  aero_sr650(22,:) = (/10.0571, 9.28994, -999.000, -999.000/)
581  aero_bgaod(22,:) = (/0.34500, 0.29700, 0.17300, 0.16400/)
582 ! aero_bgaod(22,:) = (/0.32718, 0.32547, -999.00000, 0.22936/)
583 
584 ! -- CCNY
585  aero_sites(23) = 'CCNY'
586  aero_types(23) = 4
587  aero_zones(23) = 25
588  aero_elev(23) = 0.0
589  aero_sr412(23,:) = (/5.7380,6.3655,8.7437,5.3349/)
590  aero_sr470(23,:) = (/7.0723,7.5391,8.8168,6.8278/)
591  aero_sr650(23,:) = (/10.1025,10.7149,10.1311,10.5906/)
592  aero_bgaod(23,:) = (/0.04800, 0.06600, 0.13500, 0.06100/)
593 ! aero_bgaod(23,:) = (/0.06593, 0.09566, 0.09318, 0.05144/)
594 
595 ! -- Ilorin
596  aero_sites(24) = 'Ilorin_Transition'
597  aero_types(24) = 2
598 ! aero_zones(24) = -1 !27
599  aero_zones(24) = 27
600  aero_elev(24) = 350
601  aero_sr412(24,:) = (/4.79848, 4.13429, -999.000, -999.000/)
602  aero_sr470(24,:) = (/5.73108, 5.07124, -999.000, -999.000/)
603  aero_sr650(24,:) = (/10.0571, 9.28994, -999.000, -999.000/)
604  aero_bgaod(24,:) = (/0.34500, 0.29700, 0.17300, 0.16400/)
605 ! aero_bgaod(24,:) = (/0.32718, 0.32547, -999.00000, 0.22936/)
606 
607 ! -- SACOL
608  aero_sites(25) = 'SACOL'
609  aero_types(25) = 2
610  aero_zones(25) = 28
611  aero_elev(25) = 1965
612  aero_sr412(25,:) = (/6.57751, 5.85782, 4.26251, 5.79214/)
613  aero_sr470(25,:) = (/8.5020, 8.2185, 5.56137, 6.24013/)
614  aero_sr650(25,:) = (/16.6909, 16.8518, 11.5214, 12.5133/)
615  aero_bgaod(25,:) = (/0.03700, 0.05400, 0.05700, 0.03400/)
616 ! aero_bgaod(25,:) = (/0.12611, 0.20761, 0.17829, 0.11342/)
617 
618 ! -- Mexico_City
619  aero_sites(26) = 'Mexico_City'
620  aero_types(26) = 4
621  aero_zones(26) = 29
622  aero_elev(26) = 2268.0
623  aero_sr412(26,:) = (/6.73461, 6.20030, -999.000, 8.10955 /)
624  aero_sr470(26,:) = (/7.50571, 7.88785, -999.000, 9.46562/)
625  aero_sr650(26,:) = (/7.7320, 10.2994, -999.000, 11.9709/)
626  aero_bgaod(26,:) = (/0.01900, 0.02100, 0.03900, 0.02600/)
627 ! aero_bgaod(26,:) = (/0.07039, 0.10752, 0.11487, 0.09446/)
628 
629 ! -- Solar Village
630  aero_sites(27) = 'Solar_Village'
631  aero_types(27) = 6
632  aero_zones(27) = 10
633  aero_elev(27) = 764.0
634  aero_sr412(27,:) = (/10.4297, 10.8623, 10.7472, 11.9705/)
635  aero_sr470(27,:) = (/15.0892, 16.1351, 16.0690, 17.0390/)
636  aero_sr650(27,:) = (/32.0747, 34.5677, 35.3692, 34.6681/)
637  aero_bgaod(27,:) = (/0.10100, 0.09800, 0.16700, 0.10900/)
638 ! aero_bgaod(27,:) = (/0.14651, 0.27687, 0.34036, 0.23912/)
639 
640 ! -- Jaipur, Thar Desert
641  aero_sites(28) = 'Jaipur'
642  aero_types(28) = 4
643  aero_zones(28) = 20
644  aero_elev(28) = 450.0
645  aero_sr412(28,:) = (/6.46991, 7.40196, 7.28651, 5.22799/)
646  aero_sr470(28,:) = (/8.49850, 9.42026, 9.49201, 7.03474/)
647  aero_sr650(28,:) = (/11.3653, 12.0653, 15.2039, 10.3618/)
648  aero_bgaod(28,:) = (/0.07100, 0.10500, 0.09500, 0.07100/)
649 ! aero_bgaod(28,:) = (/0.16877, 0.23449, 0.43655, 0.22099/)
650 
651 ! -- NW_India_Desert
652  aero_sites(29) = 'NW_India_Desert'
653  aero_types(29) = 4
654  aero_zones(29) = 30
655  aero_elev(29) = 450.0
656  aero_sr412(29,:) = (/7.09280, 5.90470, 6.97091, 4.24017/)
657  aero_sr470(29,:) = (/8.31369, 7.69160, 8.73495, 5.41526/)
658  aero_sr650(29,:) = (/11.8653, 13.1653, 15.0039, 10.9618/)
659  aero_bgaod(29,:) = (/0.07100, 0.10500, 0.09500, 0.07100/)
660 ! aero_bgaod(29,:) = (/0.16877, 0.23449, 0.43655, 0.22099/)
661 
662 ! --Yuma
663  aero_sites(30) = 'Yuma'
664  aero_types(30) = 6
665  aero_zones(30) = 31
666  aero_elev(30) = 63
667  aero_sr412(30,:) = (/6.7668, 6.9406, 8.3705, 7.4484/)
668  aero_sr470(30,:) = (/9.8905, 9.9898, 10.8432, 10.9740/)
669  aero_sr650(30,:) = (/24.7466, 24.4755, 25.5649, 25.4377/)
670  aero_bgaod(30,:) = (/0.07100, 0.12300, 0.11500, 0.08600/)
671 ! aero_bgaod(30,:) = (/0.05629, 0.12101, 0.13732, 0.07340/)
672 
673 ! -- read in base BRDF reflectivitiy @ 650nm from infile.
674  allocate(brdf650(3600,1800), stat=status)
675  if (status /= 0) then
676  print *, "ERROR: Unable to allocate array for BRDF base data: ", status
677  return
678  end if
679 
680  status = nf90_open(brdffile, nf90_nowrite, nc_id)
681  if (status /= nf90_noerr) then
682  print *, "ERROR: Failed to open deepblue lut_nc4 file: ", status
683  return
684  end if
685 
686  group_name = 'VIIRS_SURFACE_REFLECTANCE'
687  status = nf90_inq_ncid(nc_id, group_name, grp_id)
688  if (status /= nf90_noerr) then
689  print *, "ERROR: Failed to get ID of group "//trim(group_name)//": ", status
690  return
691  end if
692 
693  dset_name = 'BRDF_650'
694  status = nf90_inq_varid(grp_id, dset_name, dset_id)
695  if (status /= nf90_noerr) then
696  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
697  return
698  end if
699 
700  start2 = (/1,1/)
701  stride2 = (/1,1/)
702  edges2 = (/3600,1800/)
703  status = nf90_get_var(grp_id, dset_id, brdf650, start=start2, &
704  stride=stride2, count=edges2)
705  if (status /= nf90_noerr) then
706  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
707  return
708  end if
709 
710  status = nf90_close(nc_id)
711  if (status /= nf90_noerr) then
712  print *, "ERROR: Failed to close lut_nc4 file: ", status
713  return
714  end if
715 
716  return
717  end function load_brdf
718 
719 ! -- deallocate brdf650 array and AERONET site and surface reflectivity variables.
720  subroutine unload_brdf(status)
721  implicit none
722 
723  integer, intent(inout) :: status
724 
725  deallocate(brdf650, aero_sites, aero_types, aero_zones, stat=status)
726  if (status /= 0) then
727  print *, "ERROR: Unable to deallocate BRDF data: ", status
728  return
729  end if
730 
731  deallocate(aero_sr412, aero_sr470, aero_sr650, aero_bgaod, stat=status)
732  if (status /= 0) then
733  print *, "ERROR: Unable to deallocate AERONET SR arrays: ", status
734  return
735  end if
736 
737  return
738 
739  end subroutine unload_brdf
740 
741 ! -- calculate and return the BRDF-corrected surface reflectivity for pixel at lat,lon
742 ! -- based on matching AERONET BRDF's.
743 ! -- return codes:
744 ! -- 0 = success
745 ! -- -1 = failure due to no AERONET BRDF
746 ! -- -2 = failure due to no baseline surface reflectivity values.
747  integer function get_brdfcorr_sr(lat, lon, ra, sa, vza, amf, elev, month, ndvi, stdv, gzone, lc_type, bgaod, &
748  & sr412, sr470, sr650, use_alternate_brdf, debug) result(status)
749 
750  implicit none
751 
752  character(len=50), parameter :: func_name = "get_brdfcorr_sr"
753 
754  real, intent(in) :: lat
755  real, intent(in) :: lon
756  real, intent(in) :: ra
757  real, intent(in) :: sa ! -- scattering angle
758  real, intent(in) :: vza ! -- viewing zenith angle
759  real, intent(in) :: amf ! -- air mass factor
760  real, intent(in) :: elev ! -- surface elevation in meters
761  integer, intent(in) :: month
762  real, intent(in) :: ndvi
763  real, intent(in) :: stdv ! std. dev. of TOA412, 0.2deg radius
764  integer, intent(in) :: gzone
765  integer, intent(in) :: lc_type
766  real, intent(in) :: bgaod
767  real, intent(inout) :: sr412
768  real, intent(inout) :: sr470
769  real, intent(inout) :: sr650
770  logical, intent(in), optional :: use_alternate_brdf ! use alternate BRDF fits
771  logical, intent(in), optional :: debug
772 
773  real :: refsr650
774  integer :: ilat, ilon
775  integer :: m
776  integer :: fillcnt
777 
778  character(len=255) :: asite
779  real, dimension(:), allocatable :: maero412, maero470, maero650
780  real, dimension(:), allocatable :: mbgaod
781  integer, dimension(:), allocatable :: msiteindx
782  integer, dimension(:), allocatable :: sorted
783  real :: ab412, ab470, ab650 ! AERONET BRDF SR's
784  real :: ac412, ac470, ac650 ! AERONET BRDF constants
785  real :: xnorm_412_f1, xnorm_412_f2
786  real :: xnorm_470_f1, xnorm_470_f2
787  real :: frac, normfrac
788  real :: aod_corr_factor
789  integer :: i, ii, jj, cnt
790  integer :: season
791 
792  logical :: dflag
793 
794  real :: mb_sr412, mb_sr470, mb_sr650
795  real :: m_sr412, m_sr470, m_sr650
796  real :: v_sr412, v_sr488, v_sr670
797 
798  dflag = .false.
799  if (present(debug)) then
800  dflag = debug
801  end if
802 
803  if (dflag) then
804  print *, trim(func_name)//', lat, lon, raa, scat, elev, month, ndvi, gzone, lc, sr412, sr470, sr650: ' &
805  & , lat, lon, ra, sa, elev, month, ndvi, gzone, lc_type, sr412, sr470, sr650
806  end if
807 
808 ! -- convert geolocation into array indices.
809  ilat = floor(lat*10.0) + 900 + 1
810  ilon = floor(lon*10.0) + 1800 + 1
811 
812  if (ilat > 1800) ilat = 1800
813  if (ilon > 3600) ilon = 3600
814  if (dflag) print *, trim(func_name)//', lat, lon, ilat, ilon: ', lat, lon, ilat, ilon
815 
816 ! -- convert month to season
817  select case (month)
818  case (12,1,2)
819  season = 1
820  case(3:5)
821  season = 2
822  case (6:8)
823  season = 3
824  case (9:11)
825  season = 4
826  case default
827  print *, "ERROR: Invalid month specified: ", month
828  status = -1
829  return
830  end select
831 
832 ! -- set up our reference surface reflectance
833  refsr650 = brdf650(ilon,ilat)
834 
835 ! -- do we have an AERONET site in the same zone with the same land cover type?
836  m = 0
837  m = count(aero_zones == gzone .AND. aero_types == lc_type .AND. (elev < 500 .EQV. aero_elev < 500))
838 
839 ! -- create exception for China, europe, morocco, spain -- only match zone
840  if (gzone == 16 .OR. (gzone == 17 .OR. gzone == 2) .OR. gzone == 22) then
841  m = count(aero_zones == gzone .AND. (elev < 500 .EQV. aero_elev < 500))
842  end if
843 
844 ! -- create exception for Fresno Valley, Australia, tropical Sahel, Mexico_City - match by region only.
845  if (gzone == 18 .OR. gzone == 12 .OR. (gzone == 26 .OR. gzone == 27) .OR. gzone == 29) then
846  m = count(aero_zones == gzone)
847  end if
848 
849 ! -- create exception for high elevation Tibet/China zone - match by region only.
850  if (gzone == 28) then
851  m = count(aero_zones == gzone)
852  end if
853 
854 ! -- create exception for Jaipur zone - match by region only.
855  if (gzone == 20) then
856  m = count(aero_zones == gzone)
857  end if
858 
859  ! -- create exception for NW_India_Desert zone - match by region only.
860  if (gzone == 30) then
861  m = count(aero_zones == gzone)
862  end if
863 
864 ! -- create exception for Pune - match by region only.
865  if (gzone == 19) then
866  m = count(aero_zones == gzone)
867  end if
868 
869 ! -- create exception for Kanpur - match by region only, 9 January 2018 JLee
870  if (gzone == 15) then
871  m = count(aero_zones == gzone)
872  end if
873 
874 ! -- create exception for Sahel, geozone =5, landcover=2 to ignore elevation.
875 ! JLee added gzone 13 (N. America, urban)
876  if ((gzone == 5 .AND. lc_type == 2) .OR. gzone == 1 .or. gzone == 13) then
877  m = count(aero_zones == gzone .AND. aero_types == lc_type)
878  end if
879 
880 ! -- create exception for Barren North America, geozone =31 to ignore elevation above 750m.
881  if (gzone == 31 .AND. elev < 750) then
882  m = count(aero_zones == gzone)
883  end if
884 
885 ! -- if barren, use surface tables except in zone 2 (morocco), 12 (australia), and 14 (S. America)
886  if (gzone /= 2 .AND. gzone /= 12 .AND. gzone /= 14 .AND. gzone /= 28 .AND. &
887  & gzone /= 10 .AND. gzone /= 20 .AND. gzone /= 30 .AND. gzone /= 31) then
888  if (lc_type == 6) m = 0 ! reset over barren surfaces to force use of surface tables.
889  end if
890 
891  if (m > 0) then
892 ! -- allocate our arrays to store the matching AERONET data.
893 ! -- no explicit deallocate() as these should automatically be
894 ! -- deallocated when the function ends.
895  if (allocated(maero412)) deallocate(maero412, stat=status)
896  if (allocated(maero470)) deallocate(maero470, stat=status)
897  if (allocated(maero650)) deallocate(maero650, stat=status)
898  if (allocated(mbgaod)) deallocate(mbgaod, stat=status)
899  if (allocated(msiteindx)) deallocate(msiteindx, stat=status)
900  if (allocated(sorted)) deallocate(sorted, stat=status)
901  allocate(maero412(m), maero470(m), maero650(m), mbgaod(m), msiteindx(m), &
902  sorted(m), stat=status)
903  if (status /= 0) then
904  print *,"ERROR: Failed to allocate AERONET 650 SR match arrays: ",status
905  return
906  end if
907 
908  cnt = 0
909 
910 ! -- get and store base table SR values at each matching AERONET site at 412, 470, and 650.
911  do i = 1, size(aero_sites) ! i = AERONET site index
912  select case (gzone)
913  case (2, 16, 17, 22) ! -- china, europe, spain only match by zone and elevation -- no land cover.
914  if (aero_zones(i) == gzone .AND. (elev < 500 .EQV. aero_elev(i) < 500)) then
915  cnt = cnt + 1
916  maero412(cnt) = aero_sr412(i,season)
917  maero470(cnt) = aero_sr470(i,season)
918  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
919  mbgaod(cnt) = aero_bgaod(i,season)
920  msiteindx(cnt) = i
921 
922  if (dflag) then
923  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
924  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
925  end if
926  end if
927 
928  case (18, 12, 20, 26, 27, 28, 29, 30, 31) ! Fresno Valley, only match by region
929  if (aero_zones(i) == gzone) then
930  cnt = cnt + 1
931  maero412(cnt) = aero_sr412(i,season)
932  maero470(cnt) = aero_sr470(i,season)
933  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
934  mbgaod(cnt) = aero_bgaod(i,season)
935  msiteindx(cnt) = i
936 
937  if (dflag) then
938  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
939  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
940  end if
941  end if
942 
943  case (15, 19) ! Pune, only match by region, added Kanpur and India high elevation 31 January 2018 JLee
944  if (aero_zones(i) == gzone) then
945  cnt = cnt + 1
946  maero412(cnt) = aero_sr412(i,season)
947  maero470(cnt) = aero_sr470(i,season)
948  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
949  mbgaod(cnt) = aero_bgaod(i,season)
950  msiteindx(cnt) = i
951 
952  if (dflag) then
953  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
954  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
955  end if
956  end if
957 
958  case (1, 5, 10, 13) ! N. Africa, Solar Villge (Saudi Arabia)
959  if (aero_zones(i) == gzone .AND. aero_types(i) == lc_type) then
960  cnt = cnt + 1
961  maero412(cnt) = aero_sr412(i,season)
962  maero470(cnt) = aero_sr470(i,season)
963  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
964  mbgaod(cnt) = aero_bgaod(i,season)
965  msiteindx(cnt) = i
966 
967  if (dflag) then
968  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
969  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
970  end if
971  end if
972 
973  case default ! -- everywhere else match by land cover type and geozone and elevation.
974  if (aero_zones(i) == gzone .AND. aero_types(i) == lc_type .AND. (elev < 500 .EQV. aero_elev(i) < 500)) then
975  cnt = cnt + 1
976  maero412(cnt) = aero_sr412(i,season)
977  maero470(cnt) = aero_sr470(i,season)
978  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
979  mbgaod(cnt) = aero_bgaod(i,season)
980  msiteindx(cnt) = i
981 
982  if (dflag) then
983  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
984  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
985  end if
986  end if
987  end select
988  end do
989 
990 ! -- can we interpolate between zone's AERONET sites?
991  call sortrx(m, maero650, sorted)
992  if (refsr650 >= minval(maero650) .AND. refsr650 < maxval(maero650)) then
993 
994 ! -- find where refsr650 fits in maero650() and interpolate between the two sites
995  do i = 1, m-1
996  if (refsr650 >= maero650(sorted(i)) .AND. refsr650 < maero650(sorted(i+1))) then
997  ii = sorted(i)
998  asite = aero_sites(msiteindx(ii))
999  status = get_aeronet_brdf_sr(asite, month, ra, sa, vza, ndvi, stdv, ab412, &
1000  & ab470, ab650, ac412, ac470, ac650, use_alternate_brdf, debug=dflag)
1001  if (status /= 0) then
1002  print *, "ERROR: Failed to get BRDF-corrected SR from AERONET site: ", trim(asite), status
1003  return
1004  end if
1005 
1006  xnorm_412_f1 = ab412 / maero412(ii)
1007  xnorm_470_f1 = ab470 / maero470(ii)
1008 
1009  jj = sorted(i+1)
1010  asite = aero_sites(msiteindx(jj))
1011  status = get_aeronet_brdf_sr(asite, month, ra, sa, vza, ndvi, stdv, ab412, &
1012  & ab470, ab650, ac412, ac470, ac650, use_alternate_brdf, debug=dflag)
1013  if (status /= 0) then
1014  print *, "ERROR: Failed to get BRDF-corrected SR from AERONET site: ", trim(asite), status
1015  return
1016  end if
1017 
1018  xnorm_412_f2 = ab412 / maero412(jj)
1019  xnorm_470_f2 = ab470 / maero470(jj)
1020 
1021 ! -- calculate AERONET site weights according to 650 values and adjust table refs.
1022  frac = (refsr650-maero650(ii)) / (maero650(jj)-maero650(ii))
1023 
1024  normfrac = frac*xnorm_412_f2 + (1.0-frac)*xnorm_412_f1
1025  sr412 = get_viirs_ler412(ilat, ilon)
1026  if (sr412 < -900.0) then
1027  status = -2
1028  return
1029  end if
1030  sr412 = sr412 * normfrac
1031 
1032  normfrac = frac*xnorm_470_f2 + (1.0-frac)*xnorm_470_f1
1033  sr470 = get_viirs_ler488(ilat, ilon)
1034  if (sr470 < -900.0) then
1035  status = -2
1036  return
1037  end if
1038  sr470 = sr470 * normfrac
1039 
1040  status = 0
1041 
1042  if (dflag) then
1043  print '(A,A,F11.6)', trim(func_name),", Pixel Ref 650 SR: ", refsr650
1044  print '(A,A,2(F11.6,1X))', trim(func_name),", Pixel Baseline SR, 412, 470: ", &
1045  & get_viirs_ler412(ilat, ilon), get_viirs_ler488(ilat, ilon)
1046  print '(4(A,1X))', trim(func_name),", interp sites: ", &
1047  & trim(aero_sites(msiteindx(ii))), trim(aero_sites(msiteindx(jj)))
1048  print '(A,A,3(F11.6,1X))', trim(func_name),", calcsr412, aerosr412: ", sr412, maero412(ii), maero412(jj)
1049  print '(A,A,3(F11.6,1X))', trim(func_name),", calcsr470, aerosr470: ", sr470, maero470(ii), maero470(jj)
1050  print '(A,A,3(F11.6,1X))', trim(func_name),", calcsr650, aerosr650: ", sr650, maero650(ii), maero650(jj)
1051  print '(A,A,2(F11.6,1X))', trim(func_name),", xnorm412: ", xnorm_412_f1, xnorm_412_f2
1052  print '(A,A,2(F11.6,1X))', trim(func_name),", xnorm470: ", xnorm_470_f1, xnorm_470_f2
1053  end if
1054 
1055  exit ! jump out of loop, we're done!
1056 
1057  end if
1058  end do
1059 
1060 ! -- no interpolation, use single AERONET site.
1061  else
1062  if (refsr650 <= minval(maero650)) then
1063  ii = sorted(1) ! AERONET site w/ min. sr650 value
1064  else
1065  ii = sorted(m) ! AERONET site w/ max. sr650 value
1066  end if
1067 
1068  asite = aero_sites(msiteindx(ii))
1069  status = get_aeronet_brdf_sr(asite, month, ra, sa, vza, ndvi, stdv, ab412, ab470, &
1070  & ab650, ac412, ac470, ac650, use_alternate_brdf, debug=dflag)
1071  if (status /= 0) then
1072  print *, "ERROR: Failed ot get BRDF-corrected SR from AERONET site, single: ", trim(asite), status
1073  return
1074  end if
1075 
1076  ! correction to baseline adjustment factor for background aod, 10 January 2018 JLee
1077 ! if ((gzone == 15) .and. bgaod > 0.0 .and. mbgaod(ii) > 0.0 &
1078 ! & .and. bgaod < mbgaod(ii)) then
1079 ! if (ndvi < 0.3 .and. elev > 450) then
1080 !! select case (season)
1081 !! case (1)
1082 !! aod_corr_factor = min(0.1+(elev-300)*0.0015*amf,1.0)
1083 !! case (2)
1084 !! aod_corr_factor = min(0.1+(elev-300)*0.0010,0.5)
1085 !! case default
1086 !! aod_corr_factor = min(0.1+(elev-300)*0.0010,0.5)
1087 !! end select
1088 !
1089 ! select case (season)
1090 ! case (1)
1091 ! aod_corr_factor = 0.0
1092 ! case (2)
1093 ! aod_corr_factor = 0.0
1094 ! case (3)
1095 ! aod_corr_factor = 0.0
1096 ! case (4)
1097 ! aod_corr_factor = 0.0
1098 ! case default
1099 ! aod_corr_factor = 0.0
1100 ! end select
1101 ! xnorm_412_f1 = ab412 / (ac412+(maero412(ii)-ac412)*(aod_corr_factor*bgaod/mbgaod(ii)+(1.0-aod_corr_factor)))
1102 ! else
1103 ! xnorm_412_f1 = ab412 / (ac412+(maero412(ii)-ac412)*(0.1*bgaod/mbgaod(ii)+0.9))
1104 ! end if
1105 ! else
1106  xnorm_412_f1 = ab412 / maero412(ii)
1107 ! end if
1108 
1109  sr412 = get_viirs_ler412(ilat, ilon)
1110  if (sr412 < -900.0) then
1111  status = -2
1112  return
1113  end if
1114  sr412 = sr412 * xnorm_412_f1
1115 
1116  ! correction to baseline adjustment factor for background aod, 10 January 2018 JLee
1117 ! if ((gzone == 15) .and. bgaod > 0.0 .and. mbgaod(ii) > 0.0 &
1118 ! & .and. bgaod < mbgaod(ii)) then
1119 ! if (ndvi < 0.3 .and. elev > 450) then
1120 !! select case (season)
1121 !! case (1)
1122 !! aod_corr_factor = min(0.1+(elev-300)*0.0015*amf,1.0)
1123 !! case(2)
1124 !! aod_corr_factor = min(0.1+(elev-300)*0.0010,0.5)
1125 !! case default
1126 !! aod_corr_factor = min(0.1+(elev-300)*0.0010,0.5)
1127 !! end select
1128 !
1129 ! select case (season)
1130 ! case (1)
1131 ! aod_corr_factor = 0.0
1132 ! case (2)
1133 ! aod_corr_factor = 0.0
1134 ! case (3)
1135 ! aod_corr_factor = 0.0
1136 ! case (4)
1137 ! aod_corr_factor = 0.0
1138 ! case default
1139 ! aod_corr_factor = 0.0
1140 ! end select
1141 ! xnorm_470_f1 = ab470 / (ac470+(maero470(ii)-ac470)*(aod_corr_factor*bgaod/mbgaod(ii)+(1.0-aod_corr_factor)))
1142 ! else
1143 ! xnorm_470_f1 = ab470 / (ac470+(maero470(ii)-ac470)*(0.1*bgaod/mbgaod(ii)+0.9))
1144 ! end if
1145 ! else
1146  xnorm_470_f1 = ab470 / maero470(ii)
1147 ! end if
1148 
1149  sr470 = get_viirs_ler488(ilat, ilon)
1150  if (sr470 < -900.0) then
1151  status = -2
1152  return
1153  end if
1154  sr470 = sr470 * xnorm_470_f1
1155 
1156  status = 0
1157 
1158  if (dflag) then
1159  print '(A,A,F11.6)', trim(func_name), ", Pixel Ref 650 SR: ", refsr650
1160  print '(A,A,2(F11.6,1X))', trim(func_name), ", Pixel Baseline SR, 412, 470: ", &
1161  & get_viirs_ler412(ilat, ilon),get_viirs_ler488(ilat, ilon)
1162  print '(3(A,1X))', trim(func_name), ", interp site: ", trim(aero_sites(msiteindx(ii)))
1163  print '(A,A,2(F11.6,1X))', trim(func_name), ", calcsr412, aerosr412: ", sr412, maero412(ii)
1164  print '(A,A,2(F11.6,1X))', trim(func_name), ", calcsr470, aerosr470: ", sr470, maero470(ii)
1165  print '(A,A,2(F11.6,1X))', trim(func_name), ", calcsr650, aerosr650 : ", sr650, maero650(ii)
1166  print '(A,A,F11.6)', trim(func_name), ", xnorm412: ", xnorm_412_f1
1167  print '(A,A,F11.6)', trim(func_name), ", xnorm470: ", xnorm_470_f1
1168  print '(A,A,2(F11.6,1X))', trim(func_name), ", aerobrdf412, 470: ", ab412, ab470
1169  end if
1170 
1171  end if
1172 
1173 ! -- no AERONET sites (m==0), use table values.
1174  else
1175 
1176  sr412 = -999.0
1177  sr470 = -999.0
1178  sr650 = -999.0
1179  sr412 = get_ler412(ilat, ilon, ndvi, sa, ra) !get_viirs_modisbrdf_LER* ->get_LER*
1180  sr470 = get_ler470(ilat, ilon, ndvi, sa, ra) !7.5.2017 W.Kim
1181  sr650 = get_ler650(ilat, ilon, ndvi, sa, ra)
1182 
1183 
1184  if (dflag) then
1185 ! print '(A,A,14(F10.4))', trim(func_name), "lat, lon: ", lat, lon
1186 ! print '(A,A,3(F10.4))', trim(func_name), "MBSR412, MBSR470, MBSR650: ", mb_sr412, mb_sr470, mb_sr650
1187 ! print '(A,A,3(F10.4))', trim(func_name), "MSR412, MSR470, MSR650: ", get_modis_LER412(ilat,ilon), &
1188 ! & get_modis_LER470(ilat,ilon), get_modis_LER650(ilat,ilon)
1189 ! print '(A,A,3(F10.4))', trim(func_name), "VSR412, VSR488, VSR670: ", get_viirs_LER412(ilat,ilon), &
1190 ! & get_viirs_LER488(ilat,ilon), get_viirs_LER670(ilat,ilon)
1191  print '(A,A,3(F10.4))', trim(func_name), "final SR412, SR470, SR650: ", sr412, sr470, sr650
1192  end if
1193 
1194  status = 1
1195  end if
1196 
1197 ! -- final check
1198  if (sr412 < 0.0 .OR. sr470 < 0.0) then
1199  status = -1
1200  end if
1201 
1202  if (dflag) then
1203  print *, trim(func_name), ", table-based SR, 412, 470, 650: ", sr412, sr470, sr650
1204  print *, trim(func_name), ", final status: ", status
1205  end if
1206 
1207  return
1208 
1209  end function get_brdfcorr_sr
1210 
1211 ! -- returns surface reflectivity based on AERONET site (aero_site) BRDF and input
1212 ! -- geometry. Helper function for get_bdrfcorr_sr(). Returns -1 on failure,
1213 ! -- otherwise 0.
1214  integer function get_aeronet_brdf_sr(aero_site, month, raa, sca, vza, ndvi, stdv, s412, s470, &
1215  & s650, c412, c470, c650, use_alternate_brdf, debug) result(status)
1216 
1217  implicit none
1218 
1219  character(len=50), parameter :: func_name = "get_aeronet_brdf_sr"
1220 
1221  integer, parameter :: ndegs = 4
1222 
1223  character(len=255), intent(in) :: aero_site
1224  integer, intent(in) :: month
1225  real, intent(in) :: raa
1226  real, intent(in) :: sca
1227  real, intent(in) :: vza
1228  real, intent(in) :: ndvi
1229  real, intent(in) :: stdv
1230  real, intent(inout) :: s412
1231  real, intent(inout) :: s470
1232  real, intent(inout) :: s650
1233  real, intent(inout) :: c412
1234  real, intent(inout) :: c470
1235  real, intent(inout) :: c650
1236 ! real, intent(inout) :: ssa412
1237 ! real, intent(inout) :: ssa470
1238 ! real, intent(inout) :: ssa650
1239  logical, intent(in), optional :: use_alternate_brdf
1240  logical, intent(in), optional :: debug
1241 
1242  real, dimension(ndegs) :: co412
1243  real, dimension(ndegs) :: co470
1244  real, dimension(ndegs) :: co650
1245 
1246  integer :: season
1247 
1248  logical :: fwd_scat
1249  logical :: dflag
1250 
1251  dflag = .false.
1252  if (present(debug)) then
1253  dflag = debug
1254  end if
1255 
1256  fwd_scat = .false.
1257  if (raa < 90.0) then
1258  fwd_scat = .true.
1259  end if
1260 
1261  s412 = -999.0
1262  s470 = -999.0
1263  s650 = -999.0
1264 
1265  c412 = -999.0
1266  c470 = -999.0
1267  c650 = -999.0
1268 
1269 ! -- get season from month
1270  select case (month)
1271  case (12,1,2)
1272  season = 1
1273  case(3:5)
1274  season = 2
1275  case (6:8)
1276  season = 3
1277  case (9:11)
1278  season = 4
1279  case default
1280  print *, "ERROR: Invalid month specified: ", month
1281  status = -1
1282  return
1283  end select
1284 
1285  co412 = (/-999.0,-999.0,-999.0,-999.0/)
1286  co470 = (/-999.0,-999.0,-999.0,-999.0/)
1287  co650 = (/-999.0,-999.0,-999.0,-999.0/)
1288 
1289  select case (aero_site)
1290 ! ------------------------------------
1291  case ("Banizoumbou")
1292  select case (season)
1293  case (1)
1294  if(ndvi >= 0.15) then
1295  co470 = (/1.02169058e01, 4.243027e-02, 1.54773501e-04, 0.0/)
1296  co412 = (/6.56567239, 1.46437509e-02, 0.0, 0.0/)
1297  co650 = (/0.0, 0.0, 0.0, 0.0/)
1298  else
1299  co412 = (/5.05991244, 4.90682739e-02,0.0,0.0/)
1300  co470 = (/9.33658552, 7.10523577e-02, -2.60069034e-05,0.0/)
1301  co650 = (/0.0, 0.0, 0.0, 0.0/)
1302  end if
1303  case (2)
1304  if (ndvi >= 0.12) then
1305  co412 = (/6.39744066, 4.00276042e-02, 0.0, 0.0/)
1306  co470 = (/1.04021434e01, 5.37401649e-02, 1.11642009e-04, 0.0/)
1307  co650 = (/0.0, 0.0, 0.0, 0.0/)
1308 
1309 ! -- allow AERONET AOT<=1.0 rather than 0.5
1310 ! co412 = (/6.35012418, 2.40388121e-02, 1.99004385e-04, 0.0/)
1311 ! co470 = (/1.03240653e01, 4.68872309e-02, 1.41180318e-04, 0.0/)
1312 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1313 
1314 
1315  else
1316  co412 = (/7.4842753, 0.0,0.0,0.0/)
1317  co470 = (/1.11423275e01, 8.99414273e-02, -7.65091516e-04, 0.0/)
1318  co650 = (/0.0, 0.0, 0.0, 0.0/)
1319 
1320  ! -- all NDVI fits for NDVI < 0.12
1321  co412 = (/6.36294769, 5.40543846e-02, -1.71327907e-04, 0.0/)
1322  co470 = (/1.06517369e01, 6.01331952e-02, 0.0, 0.0/)
1323 
1324 ! -- allow AERONET AOT<=1.0 rather than 0.5
1325 ! co412 = (/5.72731182, 3.27134511e-02, 2.74284048e-04, 0.0/)
1326 ! co470 = (/1.04276182e01, 8.12197464e-02, -4.61564311e-04, 0.0/)
1327 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1328  end if
1329 
1330  case (3)
1331 ! if (ndvi >= 0.24) then
1332 ! co412 = (/4.71101627, 6.64118803e-02, -5.38844041e-04, 0.0/)
1333 ! co470 = (/7.65812386, 7.83366273e-02, -2.4482234e-04, 0.0/)
1334 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1335 ! else
1336 ! co412 = (/4.83957621, 9.91643198e-02, -4.31830448e-04, 0.0/)
1337 ! co470 = (/9.52056332, 1.18515428e-01, -8.79903107e-04, 0.0/)
1338 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1339 
1340  if (ndvi >= 0.24) then
1341  co412 = (/4.68590202, 4.79492301e-02, 0.0, 0.0/)
1342  co470 = (/7.65714295, 7.81415694e-02, -2.40306130e-04, 0.0/)
1343  co650 = (/0.0, 0.0, 0.0, 0.0/)
1344  else
1345  co412 = (/4.78835211, 8.16497137e-02, -3.62862493e-04, 0.0/)
1346  co470 = (/9.02297785, 1.21271052e-01, -1.09555283e-03, 0.0/)
1347  co650 = (/0.0, 0.0, 0.0, 0.0/)
1348 
1349 
1350 ! -- test new BRDF for summer, Banizoumbou. Trying to limit low bias in june...
1351  co412 = (/4.33902797, 8.37586808e-02, -5.54927180e-04, 0.0/)
1352  co470 = (/9.25667223, 1.14446764e-01, -1.03215095e-03, 0.0/)
1353  co650 = (/0.0, 0.0, 0.0, 0.0/)
1354 
1355  end if
1356 
1357  case (4)
1358  if (ndvi >= 0.21) then
1359  co412 = (/4.78430658, 3.2201042e-02, -1.62743787e-04, 6.68624319e-06/)
1360  co470 = (/7.8706363, 5.51922546e-02, 0.0, 0.0/)
1361  co650 = (/0.0, 0.0, 0.0, 0.0/)
1362  else
1363  co412 = (/5.239379, 4.142642525e-02, 1.66142711e-05, 0.0/)
1364  co470 = (/9.09596194, 6.99428916e-02, -2.528929176e-04, 0.0/)
1365  co650 = (/0.0, 0.0, 0.0, 0.0/)
1366  end if
1367  case default
1368  print *, "ERROR: Invalid season specified: ", season
1369  status = -1
1370  return
1371  end select
1372 
1373 ! ------------------------------------
1374  case ("Kanpur")
1375  select case (season)
1376  case (1)
1377  co412 = (/4.5439484, 7.12450582e-2, 5.1565853e-4, 0.0/)
1378  co470 = (/5.1905870, 7.0479636e-2, -7.2117339e-4, 0.0/)
1379  co650 = (/0.0, 0.0, 0.0, 0.0/)
1380  case (2)
1381  co412 = (/4.0491380, 6.5488864e-2, -2.7752629e-4, 0.0/)
1382  co470 = (/5.5883717, 7.6432090e-2, 3.1404959e-5, 0.0/)
1383  co650 = (/0.0, 0.0, 0.0, 0.0/)
1384  case (3)
1385 ! use fall BRDF, 26 January JLee, TEST
1386  co412 = (/4.7996805, 6.3598622e-2, -8.9915671e-6, 0.0/)
1387  co470 = (/5.6717516, 6.6228202e-2, 3.5839652e-4 , 0.0/)
1388  co650 = (/0.0, 0.0, 0.0, 0.0/)
1389 ! original
1390 ! co412 = (/4.76004180, -5.53951481e-02, 2.54996532e-03, 0.0/)
1391 ! co470 = (/8.72009627, -3.85232353e-02, 2.63096171e-03, 0.0/)
1392 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1393  case (4)
1394  co412 = (/4.7996805, 6.3598622e-2, -8.9915671e-6, 0.0/)
1395  co470 = (/5.6717516, 6.6228202e-2, 3.5839652e-4 , 0.0/)
1396  co650 = (/0.0, 0.0, 0.0, 0.0/)
1397  case default
1398  print *, "ERROR: Invalid season specified: ", season
1399  status = -1
1400  return
1401  end select
1402 
1403 ! ------------------------------------
1404  case ("IER_Cinzana")
1405  select case (season)
1406  case (1)
1407  if (ndvi >= 0.2) then
1408  co412 = (/3.63552866, 3.80334634e-2, 0.0, 0.0/)
1409  co470 = (/7.1468792, 4.90084709e-2, -5.8487537e-4, 2.65330779e-5/)
1410  co650 = (/0.0, 0.0, 0.0, 0.0/)
1411  else
1412  co412 = (/3.50830056, 4.45759847e-2, 0.0, 0.0/)
1413  co470 = (/7.2185198, 7.14231475e-2, 0.0, 0.0/)
1414  co650 = (/0.0, 0.0, 0.0, 0.0/)
1415  end if
1416  case (2)
1417  if(ndvi >= 0.18) then
1418  co412 = (/8.03123187, 6.31014685e-2, -3.03999188e-4, 0.0/)
1419  co470 = (/8.00850678, 5.36508158e-2, 0.0, 0.0/)
1420  co650 = (/0.0, 0.0, 0.0, 0.0/)
1421  else
1422  co412 = (/4.78540468, 4.53379041e-2, 0.0, 0.0/)
1423  co470 = (/8.55690294, 6.26426162e-2, 0.0, 0.0/)
1424  co650 = (/0.0, 0.0, 0.0, 0.0/)
1425  end if
1426  case (3)
1427  if (ndvi >= 0.3) then
1428  co412 = (/3.56969498, 1.48750348e-2, 0.0, 0.0/)
1429  co470 = (/5.218741, 3.68430117e-2, 0.0, 0.0/)
1430  co650 = (/0.0, 0.0, 0.0, 0.0/)
1431  else
1432  co412 = (/4.1364437, 3.54993284e-2, 0.0, 0.0/)
1433  co470 = (/7.68177478, 5.48823787e-2, 0.0, 0.0/)
1434  co650 = (/0.0, 0.0, 0.0, 0.0/)
1435  end if
1436 
1437  case (4)
1438  if (ndvi < 0.36) then
1439  co412 = (/3.3600304, 4.07091256e-2, -6.36564712e-4, 0.0/)
1440  co470 = (/6.00156726, 5.32555429e-2, -2.03417949e-4, 0.0/)
1441  co650 = (/0.0, 0.0, 0.0, 0.0/)
1442  else if(ndvi < 0.48) then
1443  co412 = (/2.75902271, 5.86471497e-3, 8.9298557e-4, -2.84768722e-6/)
1444  co470 = (/4.49584493, 3.2333347e-2, 1.68247099e-3, -2.08146852e-5/)
1445  co650 = (/0.0, 0.0, 0.0, 0.0/)
1446  else
1447  co412 = (/2.54155592, 0.0, 0.0, 0.0/)
1448  co470 = (/4.08158909, 7.65889923e-3, 0.0, 0.0/)
1449  co650 = (/0.0, 0.0, 0.0, 0.0/)
1450  end if
1451  case default
1452  print *, "ERROR: Invalid season specified: ", season
1453  status = -1
1454  return
1455  end select
1456 
1457 ! ------------------------------------
1458  case ("Zinder_Airport")
1459  select case (season)
1460  case (1)
1461  if (ndvi >= 0.15) then
1462  co412 = (/5.74980283, 2.39050366e-02, 0.0, 0.0/)
1463  co470 = (/1.00530139e01, 5.17129972e-02, 0.0, 0.0/)
1464  co650 = (/0.0, 0.0, 0.0, 0.0/)
1465  else
1466  co412 = (/5.86499038, 4.16328036e-02, 0.0, 0.0/)
1467  co470 = (/1.07113413e01, 6.94885771e-02, -2.12100636e-04, 0.0/)
1468  co650 = (/0.0, 0.0, 0.0, 0.0/)
1469  end if
1470  case (2)
1471  co412 = (/5.48605593, 7.32715822e-02, -3.94126361e-04, 0.0/)
1472  co470 = (/1.02289147e01, 7.179364421e-02, 0.0, 0.0/)
1473  co650 = (/0.0, 0.0, 0.0, 0.0/)
1474  case (3)
1475  if (ndvi >= 0.24) then
1476  co412 = (/3.72175525, 1.33333812e-03, 0.0, 0.0/)
1477  co470 = (/6.28406012, 6.05189262e-02, 0.0, 0.0/)
1478  co650 = (/0.0, 0.0, 0.0, 0.0/)
1479 
1480  else if (ndvi >= 0.15) then
1481  co412 = (/9.14958326, -6.22526837e-03, 0.0, 0.0/)
1482  co470 = (/1.22197489e01, 3.78885944e-02, 0.0, 0.0/)
1483  co650 = (/0.0, 0.0, 0.0, 0.0/)
1484 ! if (use_alternate_brdf) then
1485 ! co412 = (/6.00999178, -2.42563433e-03, 0.0, 0.0 /)
1486 ! co470 = (/9.32222748, 0.0, 0.0, 0.0/)
1487 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1488  else
1489  co412 = (/5.21423049, 8.21993929e-02, -3.75107523e-04, 0.0/)
1490  co470 = (/9.78066195, 8.69504404e-02, -3.28108722e-04, 0.0/)
1491  co650 = (/0.0, 0.0, 0.0, 0.0/)
1492  end if
1493 
1494  case (4)
1495  if (ndvi >= 0.24) then
1496  co412 = (/2.07354907, 5.40878937e-02, 0.0, 0.0/)
1497  co470 = (/5.31006297, 8.37948079e-02, 0.0, 0.0/)
1498  co650 = (/0.0, 0.0, 0.0, 0.0/)
1499  else
1500  co412 = (/5.05835071, 1.82023167e-02, -6.29515824e-04, 2.93686368e-05/)
1501  co470 = (/9.26108740, 6.81130675e-02, 0.0, 0.0/)
1502  co650 = (/0.0, 0.0, 0.0, 0.0/)
1503  end if
1504  case default
1505  print *, "ERROR: Invalid season specified: ", season
1506  status = -1
1507  return
1508  end select
1509 
1510 ! ------------------------------------
1511  case ("Beijing")
1512  select case (season)
1513  case (1)
1514  co412 = (/6.3014686, 4.1543979e-2, 1.1858985e-4, 0.0/)
1515  co470 = (/7.4044324, 8.1265848e-2, 4.9485414e-4, 0.0/)
1516  co650 = (/0.0, 0.0, 0.0, 0.0/)
1517  case (2)
1518  if (ndvi < 0.18) then
1519  co412 = (/5.89152474, 4.52651696e-2, 2.68647127e-4, 0.0/)
1520  co470 = (/7.30775670, 7.62461937e-2, -3.21229444e-4, 0.0/)
1521  co650 = (/0.0, 0.0, 0.0, 0.0/)
1522  else
1523  co412 = (/5.30165348, 2.39439950e-2, 7.06604780e-4, 0.0/)
1524  co470 = (/6.28190845, 6.15060495e-2, 1.20706642e-4, 0.0/)
1525  co650 = (/0.0, 0.0, 0.0, 0.0/)
1526  end if
1527  case (3)
1528  co412 = (/5.6957808, 5.3492403e-2, -2.1731312e-4, 0.0/)
1529  co470 = (/6.1378929, 7.4536939e-2, -3.7338370e-4, 0.0/)
1530  co650 = (/0.0, 0.0, 0.0, 0.0/)
1531  case (4)
1532  co412 = (/5.4468575, 4.9992086e-2, 1.0863964e-05, 0.0/)
1533  co470 = (/6.1302000, 6.7842888e-2, 6.9728565e-05, 0.0/)
1534  co650 = (/0.0, 0.0, 0.0, 0.0/)
1535  case default
1536  print *, "ERROR: Invalid season specified: ", season
1537  status = -1
1538  return
1539  end select
1540 
1541 ! ------------------------------------
1542  case ("Hamim")
1543  select case (season)
1544  case (1)
1545  co412 = (/10.226094, -0.14939743, 0.0064489043, -7.3014348e-05/)
1546  co470 = (/14.875093, 0.046262226, -0.0010471590, 1.1772507e-05/)
1547  co650 = (/34.573460, 0.39409698, -0.017102505, 0.00021277064/)
1548  ! ssa412 = 0.94
1549  ! ssa470 = 0.96
1550  ! ssa650 = 0.995
1551  case (2)
1552  co412 = (/7.1646428, 0.15052042, -0.0043741791, 4.4118414e-05/)
1553  co470 = (/12.347033, 0.22954843, -0.0069846621, 7.1241796e-05/)
1554  co650 = (/34.616283, 0.042627358, -0.0013109076, 2.2689966e-05/)
1555 ! ssa412 = 0.94
1556 ! ssa470 = 0.96
1557 ! ssa650 = 0.995
1558  case (3)
1559  co412 = (/12.806989, -0.46510965, 0.016412267, -0.00016780296/)
1560  co470 = (/19.796796, -0.62064603, 0.021296302, -0.00021068886/)
1561  co650 = (/32.705724, 0.12309721, -0.0029126864, 3.7611775e-05/)
1562 ! ssa412 = 0.94
1563 ! ssa470 = 0.96
1564 ! ssa650 = 0.995
1565  case (4)
1566  co412 = (/8.4939626, 0.062900115, -0.0016468367, 1.5106109e-05/)
1567  co470 = (/15.206425, 0.020553284, -0.0013703752, 2.2283588e-05/)
1568  co650 = (/34.954706, 0.17635488, -0.0058044940, 5.6107481e-05/)
1569 ! ssa412 = 0.94
1570 ! ssa470 = 0.96
1571 ! ssa650 = 0.995
1572  case default
1573  print *, "ERROR: Invalid season specified: ", season
1574  status = -1
1575  return
1576  end select
1577 
1578 ! ------------------------------------
1579  case ("Fresno_2")
1580  select case (season)
1581  case (1)
1582  co412 = (/5.80751073, 4.06728637e-02, 4.24590213e-05, 0.0/)
1583  co470 = (/7.20443297, 7.07862547e-02, 5.50556530e-04, 0.0/)
1584  co650 = (/0.0, 0.0, 0.0, 0.0/)
1585  case (2)
1586 ! if (ndvi < 0.28) then
1587 ! co412 = (/6.40431062, 3.72488428e-02, -1.66166477e-03, 3.28633059e-05/)
1588 ! co470 = (/7.69437062, 6.82783655e-02, -6.49639866e-04, 7.40504460e-06/)
1589 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1590 ! else
1591  co412 = (/5.10554282, 3.12540398e-02, 3.70094580e-04, 0.0/)
1592  co470 = (/6.98775847, 6.37364825e-02, -5.27383741e-05, 0.0/)
1593  co650 = (/0.0, 0.0, 0.0, 0.0/)
1594 ! end if
1595  case (3)
1596 ! if (ndvi < 0.28) then
1597 ! co412 = (/5.58406544, 1.61289652e-02, 6.22273421e-04, 0.0/)
1598 ! co470 = (/7.11813056, 4.77749714e-02, 4.23934048e-04, 0.0/)
1599 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1600 ! else
1601  co412 = (/4.76062810, 4.07850599e-02, 0.0, 0.0/)
1602  co470 = (/6.85966085, 5.99596507e-02, -8.44790522e-04, 2.47006074e-05/)
1603  co650 = (/0.0, 0.0, 0.0, 0.0/)
1604 ! end if
1605  case (4)
1606 ! if (ndvi < 0.27) then
1607 ! co412 = (/4.63756258, 4.98512265e-02, 0.0, 0.0/)
1608 ! co470 = (/6.85551799, 5.0385959e-02, -1.39476331e-04, 2.59945517e-05/)
1609 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
1610 ! else
1611  co412 = (/4.53821328, 2.89784912e-02, 6.46309542e-04, 0.0/)
1612  co470 = (/6.80695142, 5.35553957e-02, 1.21293340e-04, 5.95530797e-06/)
1613  co650 = (/0.0, 0.0, 0.0, 0.0/)
1614 ! end if
1615  case default
1616  print *, "ERROR: Invalid season specified: ", season
1617  status = -1
1618  return
1619  end select
1620 
1621  ! ------------------------------------
1622  case ("Fresno_GZ18")
1623  select case (season)
1624  case (1)
1625  co412 = (/5.80751073, 4.06728637e-02, 4.24590213e-05, 0.0/)
1626  co470 = (/7.20443297, 7.07862547e-02, 5.50556530e-04, 0.0/)
1627  co650 = (/0.0, 0.0, 0.0, 0.0/)
1628  case (2)
1629  if (ndvi < 0.28) then
1630  co412 = (/6.40431062, 3.72488428e-02, -1.66166477e-03, 3.28633059e-05/)
1631  co470 = (/7.69437062, 6.82783655e-02, -6.49639866e-04, 7.40504460e-06/)
1632  co650 = (/0.0, 0.0, 0.0, 0.0/)
1633  else
1634  co412 = (/5.10554282, 3.12540398e-02, 3.70094580e-04, 0.0/)
1635  co470 = (/6.98775847, 6.37364825e-02, -5.27383741e-05, 0.0/)
1636  co650 = (/0.0, 0.0, 0.0, 0.0/)
1637  end if
1638  case (3)
1639  if (ndvi < 0.28) then
1640  co412 = (/5.58406544, 1.61289652e-02, 6.22273421e-04, 0.0/)
1641  co470 = (/7.11813056, 4.77749714e-02, 4.23934048e-04, 0.0/)
1642  co650 = (/0.0, 0.0, 0.0, 0.0/)
1643  else
1644  co412 = (/4.76062810, 4.07850599e-02, 0.0, 0.0/)
1645  co470 = (/6.85966085, 5.99596507e-02, -8.44790522e-04, 2.47006074e-05/)
1646  co650 = (/0.0, 0.0, 0.0, 0.0/)
1647  end if
1648  case (4)
1649  if (ndvi < 0.27) then
1650  co412 = (/4.63756258, 4.98512265e-02, 0.0, 0.0/)
1651  co470 = (/6.85551799, 5.0385959e-02, -1.39476331e-04, 2.59945517e-05/)
1652  co650 = (/0.0, 0.0, 0.0, 0.0/)
1653  else
1654  co412 = (/4.53821328, 2.89784912e-02, 6.46309542e-04, 0.0/)
1655  co470 = (/6.80695142, 5.35553957e-02, 1.21293340e-04, 5.95530797e-06/)
1656  co650 = (/0.0, 0.0, 0.0, 0.0/)
1657  end if
1658  case default
1659  print *, "ERROR: Invalid season specified: ", season
1660  status = -1
1661  return
1662  end select
1663 
1664 ! ------------------------------------
1665  case ("CCNY")
1666  select case (season)
1667  case (1)
1668  co412 = (/6.9337283, 4.4282749e-02, 1.4061984e-03, 0.0/)
1669  co470 = (/7.3485598, 6.9214518e-02, 1.8788394e-03, 0.0/)
1670  co650 = (/0.0, 0.0, 0.0, 0.0/)
1671  case (2)
1672  co412 = (/6.5373929, 2.6971498e-02, -7.8218577e-05, 0.0/)
1673  co470 = (/7.2815217, 4.3698874e-02, -2.7398479e-04, 0.0/)
1674  co650 = (/0.0, 0.0, 0.0, 0.0/)
1675  case (3)
1676  co412 = (/6.6297657, 3.1107265e-02, -1.2153919e-04, 0.0/)
1677  co470 = (/6.8517577, 5.2723244e-02, -4.9795072e-04, 0.0/)
1678  co650 = (/0.0, 0.0, 0.0, 0.0/)
1679  case (4)
1680  co412 = (/6.1744159, 1.5031182e-02, 0.0, 0.0/)
1681  co470 = (/6.7001040, 2.5827169e-02, 0.0, 0.0/)
1682  co650 = (/0.0, 0.0, 0.0, 0.0/)
1683  case default
1684  print *, "ERROR: Invalid season specified: ", season
1685  status = -1
1686  return
1687  end select
1688 
1689 ! ------------------------------------
1690  case ("Agoufou")
1691  if (fwd_scat) then ! forward scattering
1692  select case (season)
1693  case (1)
1694  co412 = (/4.79872574, -1.56512429e-02, -1.23860221e-03, 5.84017625e-05/)
1695  co470 = (/8.05072532, 1.61294620e-02, -6.57200682e-04, 4.10211916e-05/)
1696  co650 = (/0.0, 0.0, 0.0, 0.0/)
1697  case (2)
1698  co412 = (/5.34279489, 2.40838594e-03, 0.0, 0.0/)
1699  co470 = (/8.28211141, 2.88113903e-02, 0.0, 0.0/)
1700  co650 = (/0.0, 0.0, 0.0, 0.0/)
1701  case (3)
1702  if (ndvi >= 0.24) then
1703  co412 = (/3.26738286, 4.36827818e-02, -1.55895303e-04, -1.20224162e-05/)
1704  co470 = (/5.03384478, 7.29893383e-02, 1.31678743e-03, -4.31578699e-05/)
1705  co650 = (/0.0, 0.0, 0.0, 0.0/)
1706  else
1707  co412 = (/4.49283427, 4.04848382e-05, -3.09039795e-04, 1.65524662e-05/)
1708  co470 = (/7.34716100, 4.10633137e-02, 2.51289909e-04, -3.32283482e-06/)
1709  co650 = (/0.0, 0.0, 0.0, 0.0/)
1710  end if
1711  case (4)
1712  if (ndvi >= 0.21) then
1713  co412 = (/3.21406439, 2.84017859e-02, 2.25979209e-04, -1.35954941e-05/)
1714  co470 = (/5.32086992, 5.10973584e-02, 1.23563583e-03, -3.14731061e-05/)
1715  co650 = (/0.0, 0.0, 0.0, 0.0/)
1716  else if (ndvi >= 0.18) then
1717  co412 = (/4.03496081, -1.16119226e-02, -4.21409772e-04, 3.26077680e-05/)
1718  co470 = (/6.89540010, 3.44825524e-02, 4.25223284e-04, 0.0/)
1719  co650 = (/0.0, 0.0, 0.0, 0.0/)
1720  else
1721  co412 = (/4.68551647, 3.37375535e-03, 3.28094666e-04, 0.0/)
1722  co470 = (/7.97076041, 4.07903024e-02, 0.0, 0.0/)
1723  co650 = (/0.0, 0.0, 0.0, 0.0/)
1724  end if
1725  case default
1726  print *, "ERROR: Invalid season specified: ", season
1727  status = -1
1728  return
1729  end select
1730 
1731  else ! backward scattering
1732  select case (season)
1733  case (1)
1734  co412 = (/4.79872574, -1.56512429e-02, -1.23860221e-03, 5.84017625e-05/)
1735  co470 = (/8.05072532, 1.61294620e-02, -6.57200682e-04, 4.10211916e-05/)
1736  co650 = (/0.0, 0.0, 0.0, 0.0/)
1737  case (2)
1738  co412 = (/5.31125838, 1.14257083e-02, 0.0, 0.0/)
1739  co470 = (/8.30402936, 4.22170099e-02, 0.0, 0.0/)
1740  co650 = (/0.0, 0.0, 0.0, 0.0/)
1741  case (3)
1742  if (ndvi >= 0.24) then
1743  co412 = (/3.26738286, 4.36827818e-02, -1.55895303e-04, -1.20224162e-05/)
1744  co470 = (/5.03384478, 7.29893383e-02, 1.31678743e-03, -4.31578699e-05/)
1745  co650 = (/0.0, 0.0, 0.0, 0.0/)
1746  else
1747  co412 = (/4.49283427, 4.04848382e-05, -3.09039795e-04, 1.65524662e-05/)
1748  co470 = (/7.34716100, 4.10633137e-02, 2.51289909e-04, -3.32283482e-06/)
1749  co650 = (/0.0, 0.0, 0.0, 0.0/)
1750  end if
1751  case (4)
1752  if (ndvi >= 0.21) then
1753  co412 = (/3.21406439, 2.84017859e-02, 2.25979209e-04, -1.35954941e-05/)
1754  co470 = (/5.32086992, 5.10973584e-02, 1.23563583e-03, -3.14731061e-05/)
1755  co650 = (/0.0, 0.0, 0.0, 0.0/)
1756  else if (ndvi >= 0.18) then
1757  co412 = (/4.03496081, -1.16119226e-02, -4.21409772e-04, 3.26077680e-05/)
1758  co470 = (/6.89540010, 3.44825524e-02, 4.25223284e-04, 0.0/)
1759  co650 = (/0.0, 0.0, 0.0, 0.0/)
1760  else
1761  co412 = (/4.68551647, 3.37375535e-03, 3.28094666e-04, 0.0/)
1762  co470 = (/7.97076041, 4.07903024e-02, 0.0, 0.0/)
1763  co650 = (/0.0, 0.0, 0.0, 0.0/)
1764  end if
1765  case default
1766  print *, "ERROR: Invalid season specified: ", season
1767  status = -1
1768  return
1769  end select
1770  end if
1771 
1772 ! ------------------------------------
1773  case ("Tinga_Tingana")
1774  if (fwd_scat) then ! forward scattering
1775  select case (season)
1776  case (1)
1777  if (ndvi >= 0.13) then
1778  co412 = (/9.20413537, -5.17086422e-03, 1.02106845e-04, 0.0/)
1779  co470 = (/1.22306875e01, 4.82832263e-02, 3.68569587e-04, 0.0/)
1780  co650 = (/0.0, 0.0, 0.0, 0.0/)
1781  else
1782  co412 = (/9.43803716, -3.72278076e-03 , 0.0, 0.0/)
1783  co470 = (/1.27377047e01, 8.35333189e-03, 0.0, 0.0/)
1784  co650 = (/0.0, 0.0, 0.0, 0.0/)
1785  end if
1786  case (2)
1787  if (ndvi >= 0.18) then
1788  co412 = (/8.92737977, 1.76851898e-02, 0.0, 0.0/)
1789  co470 = (/12.634865, 0.028769372, -0.00041455473, -3.2556186e-05/)
1790  co650 = (/0.0, 0.0, 0.0, 0.0/)
1791  else
1792  co412 = (/9.37232462, -9.65154143e-03, -1.74009834e-04, 0.0/)
1793  co470 = (/12.634865, 0.028769372, -0.00041455473, -3.2556186e-05/)
1794  co650 = (/0.0, 0.0, 0.0, 0.0/)
1795  end if
1796  case (3)
1797  if (ndvi >= 0.20) then
1798  co412 = (/7.81846282, 3.15351932e-03, 0.0, 0.0/)
1799  co470 = (/1.08279281e01, 1.57698665e-02, 0.0, 0.0/)
1800  co650 = (/0.0, 0.0, 0.0, 0.0/)
1801  else if (ndvi >= 0.14) then
1802  co412 = (/8.88977803, 1.51799616e-03, -7.23417787e-05, 0.0/)
1803  co470 = (/1.20676913e01, 2.91883388e-02, 0.0, 0.0/)
1804  co650 = (/0.0, 0.0, 0.0, 0.0/)
1805  else
1806  co412 = (/9.08868817, -4.17799194e-02, -8.09302376e-04, 0.0/)
1807  co470 = (/1.25503323e01, -3.95329882e-02, -1.77305946e-03, 0.0/)
1808  co650 = (/0.0, 0.0, 0.0, 0.0/)
1809  end if
1810  case (4)
1811  if (ndvi >= 0.14) then
1812  co412 = (/8.87184595, -1.57754324e-02, 0.0, 0.0/)
1813  co470 = (/1.19334546e01, 8.68690821e-03, 0.0, 0.0/)
1814  co650 = (/0.0, 0.0, 0.0, 0.0/)
1815  else
1816  co412 = (/9.09342651, -4.17208574e-02, 0.0, 0.0/)
1817  co470 = (/1.23033719e01, -5.36893150e-02, -8.53259219e-04, 7.49332728e-05/)
1818  co650 = (/0.0, 0.0, 0.0, 0.0/)
1819  end if
1820  case default
1821  print *, "ERROR: Invalid season specified: ", season
1822  status = -1
1823  return
1824  end select
1825 
1826  else ! backward scattering
1827  select case (season)
1828  case (1)
1829  if (ndvi >= 0.12) then
1830  co412 = (/9.41470858, -2.15844867e-03, -1.82266839e-04, 1.21977424e-05/)
1831  co470 = (/1.2501821e01, 4.02391785e-02, 2.08696099e-04, 1.11738774e-06/)
1832  co650 = (/0.0, 0.0, 0.0, 0.0/)
1833  else
1834  co412 = (/1.02358733e01, 7.77620010e-02, -1.98193828e-03, 0.0/)
1835  co470 = (/1.36183155e01, 4.05909269e-02, 0.0, 0.0/)
1836  co650 = (/0.0, 0.0, 0.0, 0.0/)
1837  end if
1838  case (2)
1839  if (ndvi >= 0.18) then
1840  co412 = (/7.98223150, 1.40752752e-02, 2.69501591e-03, 0.0/)
1841  co470 = (/1.25564034e01, 5.50899365e-02, 0.0, 0.0/)
1842  co650 = (/0.0, 0.0, 0.0, 0.0/)
1843  else
1844  co412 = (/9.42624421, 1.27763170e-02, 3.65495933e-04, -1.96877371e-05/)
1845  co470 = (/1.30602664e01, 7.57287787e-02, 4.73549830e-04, -6.40350281e-05/)
1846  co650 = (/0.0, 0.0, 0.0, 0.0/)
1847  end if
1848  case (3)
1849  if (ndvi >= 0.20) then
1850  co412 = (/7.89996147, -8.14332506e-03, -7.83342101e-04, 0.0/)
1851  co470 = (/1.13849147e01, 3.69927333e-02, -3.88390040e-04, 0.0/)
1852  co650 = (/0.0, 0.0, 0.0, 0.0/)
1853  else if (ndvi >= 0.14) then
1854  co412 = (/8.64034181, 1.67726763e-03, 5.88861610e-04, 0.0/)
1855  co470 = (/1.24428324e01, 3.71238324e-02, -6.76748814e-04, 0.0/)
1856  co650 = (/0.0, 0.0, 0.0, 0.0/)
1857 
1858  else
1859  co412 = (/9.41753918, -2.67338094e-02, -8.88155712e-04, 0.0/)
1860  co470 = (/1.34852983e01, 1.12436978e-02, -1.61943826e-03, 0.0/)
1861  co650 = (/0.0, 0.0, 0.0, 0.0/)
1862  end if
1863  case (4)
1864  if (ndvi >= 0.14) then
1865  co412 = (/8.83070860, -1.51364763e-03, 8.54079578e-04, 0.0/)
1866  co470 = (/1.20956002e01, 3.68362395e-02, 7.40851587e-04, 0.0/)
1867  co650 = (/0.0, 0.0, 0.0, 0.0/)
1868  else
1869  co412 = (/8.88610258, -2.01943966e-02, 1.61198594e-03, 4.14828495e-06/)
1870  co470 = (/1.20856901e01, 3.26791012e-02, 2.03660386e-03, -1.72052223e-05/)
1871  co650 = (/0.0, 0.0, 0.0, 0.0/)
1872  end if
1873  case default
1874  print *, "ERROR: Invalid season specified: ", season
1875  status = -1
1876  return
1877  end select
1878  end if
1879 ! ------------------------------------
1880  case ("Moldova")
1881  select case (season)
1882  case (1)
1883  co412 = (/6.08251454, 8.6508708e-02, 1.4521957e-03, 0.0/)
1884  co470 = (/5.80924919, 6.4047214e-02, 1.4495468e-03, 0.0/)
1885  co650 = (/0.0, 0.0, 0.0, 0.0/)
1886  case (2)
1887  if (ndvi >= 0.3) then
1888  co412 = (/4.59092762, 3.22065937e-2, 1.72682251e-4, 0.0/)
1889  co470 = (/5.18390073, 5.80489830e-2, -2.1862814e-4, 0.0/)
1890  co650 = (/0.0, 0.0, 0.0, 0.0/)
1891  else
1892  co412 = (/5.34520098, 3.28317599e-2, 3.17897070e-4, 0.0/)
1893  co470 = (/6.08505785, 5.89311646e-2, 2.59308378e-4, 0.0/)
1894  co650 = (/0.0, 0.0, 0.0, 0.0/)
1895  end if
1896  case (3)
1897  co412 = (/4.41373796, 2.74747266e-2, -9.0896914e-5, 0.0/)
1898  co470 = (/4.84420545, 4.30808241e-2, -5.4624034e-5, 0.0/)
1899  co650 = (/0.0, 0.0, 0.0, 0.0/)
1900  case (4)
1901  if (ndvi >= 0.3) then
1902  co412 = (/4.45954687, 2.77637428e-2, 7.73159082e-4, 0.0/)
1903  co470 = (/5.06433779, 5.27772907e-2, 7.80966442e-4, 0.0/)
1904  co650 = (/0.0, 0.0, 0.0, 0.0/)
1905  else
1906  co412 = (/5.22111926, 9.79821719e-2, 2.74956928e-3, 0.0/)
1907  co470 = (/5.63105884, 1.20658024e-1, 2.76971745e-3, 0.0/)
1908  co650 = (/0.0, 0.0, 0.0, 0.0/)
1909  end if
1910  case default
1911  print *, "ERROR: Invalid season specified: ", season
1912  status = -1
1913  return
1914  end select
1915 
1916 ! ------------------------------------
1917  case ("Modena")
1918  select case (season)
1919  case (1)
1920  co412 = (/4.8756241, 6.2534569e-2, 1.3572766e-3, 0.0/)
1921  co470 = (/5.4655822, 9.2120653e-2, 2.2203512e-3, 0.0/)
1922  co650 = (/0.0, 0.0, 0.0, 0.0/)
1923  case (2)
1924  co412 = (/5.0263816, 2.5373434e-2, 3.9146226e-4, 0.0/)
1925  co470 = (/5.4623850, 3.9852901e-2, 2.4863178e-4, 0.0/)
1926  co650 = (/0.0, 0.0, 0.0, 0.0/)
1927  case (3)
1928  co412 = (/5.1737469, 3.5232032e-2, -2.7832108e-4, 0.0/)
1929  co470 = (/5.4415591, 5.7405000e-2, -3.7084290e-4, 0.0/)
1930  co650 = (/0.0, 0.0, 0.0, 0.0/)
1931  case (4)
1932  co412 = (/3.57525283, 4.76106748e-2, 0.0, 0.0/)
1933  co470 = (/5.07540158, 6.07470043e-2, 0.0, 0.0/)
1934  co650 = (/0.0, 0.0, 0.0, 0.0/)
1935  case default
1936  print *, "ERROR: Invalid season specified: ", season
1937  status = -1
1938  return
1939  end select
1940 
1941 ! ------------------------------------
1942  case ("Ispra")
1943  select case (season)
1944  case (1)
1945  co412 = (/2.94840397, 7.50469276e-02, -8.55631487e-03, 2.27740054e-04/)
1946  co470 = (/3.84084962, 2.46123068e-02, -3.93096482e-03, 1.39839185e-04/)
1947  co650 = (/5.32222028, 4.87768133e-02, 4.22486516e-03, -1.01546887e-04/)
1948  ! ssa412 = 0.96
1949  ! ssa470 = 0.96
1950  ! ssa650 = 0.995
1951  case (2)
1952  if (ndvi < 0.42) then
1953  co412 = (/2.13608185, -1.16229203e-02, 2.94401536e-03, -4.50006125e-05/)
1954  co470 = (/2.49471720, 2.33437868e-02, 3.68220345e-03, -7.55117909e-05/)
1955  co650 = (/3.45073310, 2.58147011e-01, -6.23027605e-03, 5.75888737e-05/)
1956  else
1957  co412 = (/2.23138624, -4.08180960e-02, 2.65231326e-03, -3.66271249e-05/)
1958  co470 = (/2.53458698, -5.68549547e-03, 1.36468352e-03, -1.8128715e-05/)
1959  co650 = (/3.3522585, 1.75290271e-02, 3.74108282e-04, -4.21350245e-06/)
1960  end if
1961 ! ssa412 = 0.96
1962 ! ssa470 = 0.96
1963 ! ssa650 = 0.995
1964  case (3)
1965  co412 = (/5.85428528, -4.40189848e-01, 1.40438945e-02, -1.30337719e-04/)
1966  co470 = (/5.56715596, -3.51677373e-01, 1.13826478e-02, -1.01625742e-04/)
1967  co650 = (/5.32153704, -2.47300042e-01, 8.34454443e-03, -6.98915803e-05/)
1968 ! ssa412 = 0.96
1969 ! ssa470 = 0.96
1970 ! ssa650 = 0.995
1971  case (4)
1972  co412 = (/9.78051816e-01, 3.83718088e-03, 2.03033445e-03, -3.88452812e-05/)
1973  co470 = (/1.34514727, 2.32911980e-02, 2.02551784e-03, -3.87492873e-05/)
1974  co650 = (/2.47427232, 4.49367275e-02, 1.42347421e-03, -3.36743928e-05/)
1975 ! ssa412 = 0.96
1976 ! ssa470 = 0.96
1977 ! ssa650 = 0.995
1978  case default
1979  print *, "ERROR: Invalid season specified: ", season
1980  status = -1
1981  return
1982  end select
1983 
1984 ! ------------------------------------
1985  case ("Saada")
1986  if (fwd_scat) then ! forward scattering
1987  select case (season)
1988  case (1)
1989  if (ndvi >= 0.3) then
1990  co412 = (/2.64678353, 0.0, 0.0, 0.0/)
1991  co470 = (/4.30869805, 2.23352643e-02, -3.08512532e-05, 0.0/)
1992  co650 = (/0.0, 0.0, 0.0, 0.0/)
1993  else
1994  co412 = (/2.89503206, -1.10265858e-02, 8.83157740e-05, 4.86510471e-05/)
1995  co470 = (/4.85292481, 1.80204315e-02, -7.41860898e-05, 4.92511685e-05/)
1996  co650 = (/0.0, 0.0, 0.0, 0.0/)
1997  end if
1998  case (2)
1999  if (ndvi < 0.32) then
2000  co412 = (/4.18631389, 2.5289862e-02, -9.62343375e-04, 3.39909450e-05/)
2001  co470 = (/5.32132814, 5.63754659e-02, -9.39866104e-04, 2.88986833e-05/)
2002  co650 = (/0.0, 0.0, 0.0, 0.0/)
2003  else if (ndvi >= 0.32 .AND. ndvi < 0.36) then
2004  co412 = (/4.06688221, -1.77611644e-02, 0.0, 0.0/)
2005  co470 = (/4.97204509, 8.48689442e-03, 7.25410501e-04, 0.0/)
2006  co650 = (/0.0, 0.0, 0.0, 0.0/)
2007  else
2008  co412 = (/3.42376327, -1.99413791e-02, 0.0, 0.0/)
2009  co470 = (/4.27929238, 2.86227327e-02, 0.0, 0.0/)
2010  co650 = (/0.0, 0.0, 0.0, 0.0/)
2011  end if
2012  case (3)
2013  if (ndvi < 0.27) then
2014  co412 = (/4.37627766, 8.01305335e-03, 8.12666253e-04, -1.00058657e-05/)
2015  co470 = (/5.52675332, 4.58968534e-02, 5.09676314e-04, -9.71283147e-06/)
2016  co650 = (/0.0, 0.0, 0.0, 0.0/)
2017  else
2018  co412 = (/4.31991803, -4.05160123e-02, 2.50853131e-03, -4.14415804e-05/)
2019  co470 = (/5.20304491, 3.31189616e-02, 2.11258050e-04, 0.0/)
2020  co650 = (/0.0, 0.0, 0.0, 0.0/)
2021  end if
2022  case (4)
2023  if (ndvi < 0.27) then
2024  co412 = (/3.90506839, 0.0, 0.0, 0.0/)
2025  co470 = (/4.55176618, 0.0, 0.0, 0.0/)
2026  co650 = (/0.0, 0.0, 0.0, 0.0/)
2027  else
2028  co412 = (/3.71875289, 1.75827423e-03, 0.0, 0.0/)
2029  co470 = (/5.24692412, 4.20630300e-02, 0.0, 0.0/)
2030  co650 = (/0.0, 0.0, 0.0, 0.0/)
2031  end if
2032  case default
2033  print *, "ERROR: Invalid season specified: ", season
2034  status = -1
2035  return
2036  end select
2037  else ! backward scattering
2038  select case (season)
2039  case (1)
2040  if (ndvi >= 0.3) then
2041  co412 = (/2.40043582, -3.33151038e-02, 9.09508864e-04, 4.12504587e-05/)
2042  co470 = (/4.25935855, 9.65676859e-03, 2.92691096e-04, 2.94546746e-05/)
2043  co650 = (/0.0, 0.0, 0.0, 0.0/)
2044  else
2045  co412 = (/2.79446907, 0.0, 0.0, 0.0/)
2046  co470 = (/4.85292481, 1.80204315e-02, -7.41860898e-05, 4.92511685e-05/)
2047  co650 = (/0.0, 0.0, 0.0, 0.0/)
2048  end if
2049  case (2)
2050  if (ndvi < 0.32) then
2051  co412 = (/3.77066492, 1.58922076e-02, 3.03098949e-04, 0.0/)
2052  co470 = (/5.03028472, 5.31452578e-02, 1.26507640e-04, 0.0/)
2053  co650 = (/0.0, 0.0, 0.0, 0.0/)
2054  else if (ndvi >= 0.32 .AND. ndvi < 0.36) then
2055  co412 = (/4.15714313, -1.65945058e-02, -3.80237318e-04, 1.50147243e-05/)
2056  co470 = (/5.00549166, 1.15932385e-02, 6.83756479e-04, 0.0/)
2057  co650 = (/0.0, 0.0, 0.0, 0.0/)
2058  else
2059  co412 = (/3.09370523, -3.88747605e-02, 1.03242387e-03, 0.0/)
2060  co470 = (/4.35868847, 1.25746607e-02, -9.70954354e-04, 4.01565514e-05/)
2061  co650 = (/0.0, 0.0, 0.0, 0.0/)
2062  end if
2063  case (3)
2064  if (ndvi < 0.27) then
2065  co412 = (/4.42122008, -1.43446348e-03, -1.26690140e-04, 1.39839144e-05/)
2066  co470 = (/5.56874754, 3.92057334e-02, -2.26222735e-04, 1.30731833e-05/)
2067  co650 = (/0.0, 0.0, 0.0, 0.0/)
2068  else
2069  co412 = (/4.45603717, -3.60020814e-02, 8.76708868e-04, 0.0/)
2070  co470 = (/5.16502610, 2.56647090e-02, 6.43566423e-04, 0.0/)
2071  co650 = (/0.0, 0.0, 0.0, 0.0/)
2072  end if
2073  case (4)
2074  if (ndvi < 0.27) then
2075  co412 = (/3.16438602, 6.46839077e-02, 0.0, 0.0/)
2076  co470 = (/4.63876927, 9.09174541e-02, 0.0, 0.0/)
2077  co650 = (/0.0, 0.0, 0.0, 0.0/)
2078  else
2079  co412 = (/3.45291249, -2.23746051e-03, 6.18819075e-04, 0.0/)
2080  co470 = (/5.09438639, 3.96335945e-02, 3.59544361e-04, 0.0/)
2081  co650 = (/0.0, 0.0, 0.0, 0.0/)
2082  end if
2083  case default
2084  print *, "ERROR: Invalid season specified: ", season
2085  status = -1
2086  return
2087  end select
2088  endif
2089 
2090 ! ------------------------------------
2091  case ("Palencia")
2092  select case (season)
2093  case (1)
2094  if (ndvi < 0.28) then
2095  co412 = (/2.68778125, 3.16549893e-02,0.0,0.0/)
2096  co470 = (/5.44559746,0.0,0.0,0.0/)
2097  co650 = (/0.0, 0.0, 0.0, 0.0/)
2098  else
2099  co412 = (/2.94527862, 0.0,0.0,0.0/)
2100  co470 = (/5.422391543, 7.49454787e-03,0.0,0.0/)
2101  co650 = (/0.0, 0.0, 0.0, 0.0/)
2102  end if
2103 
2104  case (2)
2105  if (ndvi >= 0.5) then
2106  co412 = (/2.11712331, 1.89785795e-02, -3.36702190e-04, 1.02791555e-05/)
2107  co470 = (/4.12074484, 3.94824004e-02, 0.0, 0.0/)
2108  co650 = (/0.0, 0.0, 0.0, 0.0/)
2109 
2110  else if (ndvi < 0.4) then
2111  co412 = (/3.38904321, 2.76987802e-02, 0.0, 0.0/)
2112  co470 = (/6.42545968, 5.19763334e-02, 0.0, 0.0/)
2113  co650 = (/0.0, 0.0, 0.0, 0.0/)
2114  else
2115  co412 = (/2.43331357, 3.25327465e-02, 0.0, 0.0/)
2116  co470 = (/4.76639599, 4.15582016e-02, 1.11252132e-04, 0.0/)
2117  co650 = (/0.0, 0.0, 0.0, 0.0/)
2118  end if
2119 
2120  case (3)
2121  if (ndvi >= 0.32) then
2122  co412 = (/2.84519284, 2.72442032e-2, 0.0, 0.0/)
2123  co470 = (/6.15825559, 3.47664076e-2, 1.9403065e-4, 0.0/)
2124  co650 = (/0.0, 0.0, 0.0, 0.0/)
2125 
2126  !co412 = (/2.04842972, 2.45804399e-02, 0.0, 0.0/)
2127  !co470 = (/5.86019014, 2.96439063e-02, 0.0, 0.0/)
2128  !co650 = (/0.0, 0.0, 0.0, 0.0/)
2129  else
2130  co412 = (/2.6482836, 4.0263797e-2, 0.0, 0.0/)
2131  co470 = (/7.06495618, 4.88471232e-2, -8.39825079e-5, 0.0/)
2132  co650 = (/0.0, 0.0, 0.0, 0.0/)
2133 
2134  !co412 = (/1.90045829, -2.51858297e-03, 8.11589166e-04, 0.0/)
2135  !co470 = (/7.05691697, 4.93936950e-02, 0.0, 0.0/)
2136  !co650 = (/0.0, 0.0, 0.0, 0.0/)
2137 
2138  end if
2139 
2140  case (4)
2141  co412 = (/2.97435558, 1.72237964e-02, 0.0, 0.0/)
2142  co470 = (/7.41527891, 5.88402071e-02, 7.96356631e-05, 0.0/)
2143  co650 = (/0.0, 0.0, 0.0, 0.0/)
2144 
2145  case default
2146  print *, "ERROR: Invalid season specified: ", season
2147  status = -1
2148  return
2149  end select
2150 
2151 ! ------------------------------------
2152  case ("Lecce_University")
2153  select case (season)
2154  case (1)
2155  co412 = (/3.66811317, 2.12308807e-02, 0.0, 0.0/)
2156  co470 = (/5.10650889, 7.12197835e-02, 6.15205093e-05, 0.0/)
2157  co650 = (/0.0, 0.0, 0.0, 0.0/)
2158 
2159  case (2)
2160  if (ndvi >= 0.45) then
2161  co412 = (/3.42708429, 2.01945894e-02, 5.70725971e-04, 0.0/)
2162  co470 = (/4.23230444, 3.76471806e-02, 6.98131497e-04, 0.0/)
2163  co650 = (/0.0, 0.0, 0.0, 0.0/)
2164  else if (ndvi >= 0.40 .AND. ndvi < 0.45) then
2165  co412 = (/4.82551344, 6.13242297e-03, 0.0, 0.0/)
2166  co470 = (/5.92910956, 5.63037114e-02, -9.05894219e-04, 0.0/)
2167  co650 = (/0.0, 0.0, 0.0, 0.0/)
2168  else
2169  co412 = (/4.22986020, 2.78424337e-02, -1.44379581e-04, 0.0/)
2170  co470 = (/5.51855341, 6.20406750e-02, -2.63676847e-04, 0.0/)
2171  co650 = (/0.0, 0.0, 0.0, 0.0/)
2172  end if
2173 
2174  case (3)
2175  co412 = (/5.4920958, 4.2560058e-2, -3.3332266e-4, 0.0/)
2176  co470 = (/6.1583353, 6.8705510e-2, -2.7344898e-4, 0.0/)
2177  co650 = (/0.0, 0.0, 0.0, 0.0/)
2178 
2179  case (4)
2180  co412 = (/5.3015222, 3.2603717e-2, 4.9840706e-4, 0.0/)
2181  co470 = (/5.8268639, 5.6895741e-2, 4.2632621e-4, 0.0/)
2182  co650 = (/0.0, 0.0, 0.0, 0.0/)
2183 
2184  case default
2185  print *, "ERROR: Invalid season specified: ", season
2186  status = -1
2187  return
2188  end select
2189 
2190 ! ------------------------------------
2191  case ("Carpentras")
2192  select case (season)
2193  case (1)
2194  if (ndvi >= 0.36) then
2195  co412 = (/3.63305224, 1.57411548e-2, 0.0, 0.0/)
2196  co470 = (/5.12339543, 3.27343565e-2, 0.0, 0.0/)
2197  co650 = (/0.0, 0.0, 0.0, 0.0/)
2198  else
2199  co412 = (/4.14705645, 4.21266106e-2, 0.0, 0.0/)
2200  co470 = (/6.03776651, 6.0694725e-2, 0.0, 0.0/)
2201  co650 = (/0.0, 0.0, 0.0, 0.0/)
2202  end if
2203 
2204 ! -- 25km BRDF
2205 ! co412 = (/3.65420405, 3.19272709e-02, 3.05220414e-04, 0.0/)
2206 ! co470 = (/5.46812267, 8.72999543e-02, 1.51137682e-03, 0.0/)
2207 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2208 
2209  case (2)
2210  if (ndvi < 0.3) then
2211  co412 = (/5.31754912, 5.6181342e-2, 0.0, 0.0/)
2212  co470 = (/7.21956575, 8.6234168e-2, 0.0, 0.0/)
2213  co650 = (/0.0, 0.0, 0.0, 0.0/)
2214  else if (ndvi < 0.42) then
2215  co412 = (/4.45713707, 2.95018243e-3, -9.6135173e-4, 4.91402021e-5/)
2216  co470 = (/5.88268514, 4.70497569e-2, 3.55853726e-5, 0.0/)
2217  co650 = (/0.0, 0.0, 0.0, 0.0/)
2218  else
2219  co412 = (/3.48800908, 3.96286071e-2, 0.0, 0.0/)
2220  co470 = (/5.29642181, 4.57011215e-2, -6.90453319e-4, 3.20776151e-5/)
2221  co650 = (/0.0, 0.0, 0.0, 0.0/)
2222  end if
2223 
2224 ! -- 25km BRDF
2225 ! if (ndvi >= 0.46) then
2226 ! co412 = (/2.97987530, 2.27364122e-02, 9.88588305e-04, 0.0/)
2227 ! co470 = (/4.54948280, 4.06782524e-02, 6.53794050e-04, 0.0/)
2228 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2229 ! else if (ndvi >= 0.4) then
2230 ! co412 = (/3.42964905, -1.07598875e-02, 6.53505474e-04, 3.75382640e-05/)
2231 ! co470 = (/4.74069593, 2.36714602e-02, 8.20597094e-04, 2.07381443e-05/)
2232 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2233 ! else if (ndvi >= 0.3) then
2234 ! co412 = (/3.92563927, 3.23587748e-02, 1.11824371e-03, 0.0/)
2235 ! co470 = (/5.51160066, 5.03020135e-02, 9.10344431e-04, 0.0/)
2236 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2237 ! else
2238 ! co412 = (/5.19496351, 5.47740577e-02, 0.0, 0.0/)
2239 ! co470 = (/6.90182111, 7.42751209e-02, 0.0, 0.0/)
2240 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2241 ! end if
2242 
2243  case (3)
2244  if (ndvi < 0.42) then
2245  co412 = (/3.3539774, 4.88920328e-2, -1.7442563e-3, 4.09605495e-5/)
2246  co470 = (/5.11861399, 6.21094378e-2, 0.0, 0.0/)
2247  co650 = (/0.0, 0.0, 0.0, 0.0/)
2248  else
2249  co412 = (/2.94725072, 3.72651435e-2, 5.28386136e-4, 0.0/)
2250  co470 = (/4.75336791, 6.02706548e-2, -3.53602622e-4, 2.01191512e-5/)
2251  co650 = (/0.0, 0.0, 0.0, 0.0/)
2252  end if
2253 
2254 ! -- 25km BRDF
2255 ! if (ndvi >= 0.46) then
2256 ! co412 = (/4.33893052, 4.70373358e-02, 2.55311732e-04, -4.89431042e-06/)
2257 ! co470 = (/2.72831822, 1.99844060e-02, 4.82744505e-04, 0.0/)
2258 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2259 ! else
2260 ! co412 = (/2.72831822, 1.99844060e-02, 4.82744505e-04, 0.0/)
2261 ! co470 = (/4.75588609, 4.56984776e-02, 9.02843443e-05, 0.0/)
2262 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2263 ! end if
2264 
2265  case (4)
2266  co412 = (/3.13735391, 3.48937426e-2, 3.64366638e-4, 0.0/)
2267  co470 = (/4.56241718, 5.2711995e-2, 9.26548766e-4, 0.0/)
2268  co650 = (/0.0, 0.0, 0.0, 0.0/)
2269 
2270 ! -- 25km BRDF
2271 ! if (ndvi > 0.46) then
2272 ! co412 = (/2.90669844, 2.65353619e-02, 4.88268055e-04, 0.0/)
2273 ! co470 = (/4.17834040, 4.11956853e-02, 8.09480813e-04, 0.0/)
2274 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2275 ! else
2276 ! co412 = (/3.11168018, 1.93021460e-02, 0.0, 0.0/)
2277 ! co470 = (/4.68012390, 5.57148485e-02, 5.760506467e-04, -8.35696941e-06/)
2278 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2279 ! end if
2280 
2281  case default
2282  print *, "ERROR: Invalid season specified: ", season
2283  status = -1
2284  return
2285  end select
2286 
2287  case ("Trelew") ! backward scattering
2288  select case (season)
2289  case (1)
2290  if (ndvi < 0.2) then
2291  co412 = (/7.12231945, 4.85895624e-02, -1.28573607e-03, 2.25761306e-05/)
2292  co470 = (/9.29057722, 8.45987919e-02, -7.61137837e-04, 0.0/)
2293  co650 = (/0.0, 0.0, 0.0, 0.0/)
2294  else
2295  co412 = (/6.67352731, 2.31096853e-02, -1.07985947e-03, 5.12622592e-05/)
2296  co470 = (/8.92322447, 7.99348838e-02, 0.0, 0.0/)
2297  co650 = (/0.0, 0.0, 0.0, 0.0/)
2298  end if
2299  case (2)
2300  if (ndvi < 0.18) then
2301  co412 = (/6.79254216, 6.60335364e-02, 0.0, 0.0/)
2302  co470 = (/9.05448478, 1.01175023e-01, 1.31793002e-02, 0.0/)
2303  co650 = (/0.0, 0.0, 0.0, 0.0/)
2304  else
2305  co412 = (/6.63306271, 4.20332840e-02, 1.87758245e-04, 0.0/)
2306  co470 = (/8.71407292, 7.83112414e-02, 1.01125671e-03, 0.0/)
2307  co650 = (/0.0, 0.0, 0.0, 0.0/)
2308  end if
2309  case (3)
2310  if (ndvi < 0.15) then
2311  co412 = (/6.22897476, 0.0, 0.0, 0.0/)
2312  co470 = (/8.73022491, 0.0, 0.0, 0.0/)
2313  co650 = (/0.0, 0.0, 0.0, 0.0/)
2314  else
2315  co412 = (/5.83693596, 2.94875730e-02, 4.27587428e-04, 0.0/)
2316  co470 = (/8.12482274, 5.32465081e-02, 0.0, 0.0/)
2317  co650 = (/0.0, 0.0, 0.0, 0.0/)
2318  end if
2319  case (4)
2320  if (ndvi < 0.2) then
2321  co412 = (/9.20319079, 7.41965188e-02, -1.80650001e-04, 0.0/)
2322  co470 = (/6.17664662, 7.45518438e-02, -3.64408664e-04, -1.05957912e-05/)
2323  co650 = (/0.0, 0.0, 0.0, 0.0/)
2324  else
2325  co412 = (/8.20920358, 5.96572455e-02, 7.20029748e-04, 1.07035450e-05/)
2326  co470 = (/6.35028669, 3.72669462e-02, 1.39396118e-04, 1.09315712e-05/)
2327  co650 = (/0.0, 0.0, 0.0, 0.0/)
2328  end if
2329  case default
2330  print *, "ERROR: Invalid season specified: ", season
2331  status = -1
2332  return
2333  end select
2334 
2335  case ("Pune")
2336  select case (season)
2337  case (1)
2338  co412 = (/2.2107312, 1.9546884e-2, 1.0217331e-3, 0.0/)
2339  co470 = (/3.9707635, 4.5260501e-2, 8.2287074e-4, 0.0/)
2340  co650 = (/0.0, 0.0, 0.0, 0.0/)
2341 
2342  case (2)
2343  co412 = (/2.3410848, 1.1693201e-2, 9.9765075e-4, 0.0/)
2344  co470 = (/4.5157122, 5.7494184e-2, 2.3163434e-4, 0.0/)
2345  co650 = (/0.0, 0.0, 0.0, 0.0/)
2346 
2347  case (3)
2348  !Pune is unable to perform BRDF study at summer due to monsoon
2349  !use fall for summer, 26 January 2018, JLee TEST
2350  co412 = (/1.6509085, 3.2402477e-2, 1.5609563e-3, 0.0/)
2351  co470 = (/3.0505165, 4.3231390e-2, 1.4585233e-3, 0.0/)
2352  co650 = (/0.0, 0.0, 0.0, 0.0/)
2353 
2354  case (4)
2355  co412 = (/1.6509085, 3.2402477e-2, 1.5609563e-3, 0.0/)
2356  co470 = (/3.0505165, 4.3231390e-2, 1.4585233e-3, 0.0/)
2357  co650 = (/0.0, 0.0, 0.0, 0.0/)
2358 
2359  case default
2360  print *, "ERROR: Invalid season specified: ", season
2361  status = -1
2362  return
2363  end select
2364 
2365  case ("Evora")
2366  if (fwd_scat) then ! forward scattering
2367  select case (season)
2368  case (1)
2369  if (ndvi >= 0.54) then
2370  co412 = (/1.8666770, 0.026571400, 0.0, 0.0/)
2371  co470 = (/3.24662224, 2.49647745e-02, 0.0, 0.0/)
2372  co650 = (/0.0, 0.0, 0.0, 0.0/)
2373  else
2374  co412 = (/2.1474521, 0.019420845, 0.0, 0.0/)
2375  co470 = (/3.8045176, 0.038118250, 0.00044871309, 1.4730596e-05/)
2376  co650 = (/0.0, 0.0, 0.0, 0.0/)
2377  end if
2378  case (2)
2379  if (ndvi >= 0.54) then
2380  co412 = (/2.67001676, -1.07772899e-02, 4.98010288e-04, -7.06071474e-06/)
2381  co470 = (/3.47056999, 1.75578420e-02, 1.07148973e-04, 7.60010333e-06/)
2382  co650 = (/0.0, 0.0, 0.0, 0.0/)
2383  else if (ndvi >= 0.42) then
2384  co412 = (/3.57946117, -2.10298778e-02, -4.11579021e-04, 1.55923969e-05/)
2385  co470 = (/4.34427890, 1.57998603e-02, -5.70677301e-04, 2.11628341e-05/)
2386  co650 = (/0.0, 0.0, 0.0, 0.0/)
2387  else
2388  co412 = (/3.49153138, -1.82641547e-02, 1.71132131e-03, -2.49950954e-05/)
2389  co470 = (/4.24504494, 4.49089153e-02, 1.81406770e-03, -3.88986042e-05/)
2390  co650 = (/0.0, 0.0, 0.0, 0.0/)
2391  end if
2392  case (3)
2393  if (ndvi >= 0.36) then
2394  co412 = (/3.51804408, -5.43557298e-03, -4.11664584e-05, 4.19463147e-06/)
2395  co470 = (/4.42020622, 3.56782224e-02, 2.32453523e-04, 0.0/)
2396  co650 = (/0.0, 0.0, 0.0, 0.0/)
2397  else if (ndvi >= 0.32) then
2398  co412 = (/4.02658655, -3.41714839e-02, 1.49532934e-03, -1.20524324e-05/)
2399  co470 = (/5.29484758, 3.27714291e-02, 0.0, 0.0/)
2400  co650 = (/0.0, 0.0, 0.0, 0.0/)
2401  else if (ndvi >= 0.27) then
2402  co412 = (/4.29981928, -1.11379081e-02, 1.05046171e-03, -1.30375107e-05/)
2403  co470 = (/5.64253900, 3.74786248e-02, 5.83243337e-04, -1.00991872e-05/)
2404  co650 = (/0.0, 0.0, 0.0, 0.0/)
2405  else
2406  co412 = (/4.86874172, 2.25252861e-02, 1.87141545e-04, 0.0/)
2407  co470 = (/6.16672976, 5.10490840e-02, 9.10921618e-05, 0.0/)
2408  co650 = (/0.0, 0.0, 0.0, 0.0/)
2409  end if
2410  case (4)
2411  if (ndvi >= 0.47) then
2412  co412 = (/1.58754835, 1.20745361e-02, 0.0, 0.0/)
2413  co470 = (/2.98246568, 9.57936578e-03, 0.0, 0.0/)
2414  co650 = (/0.0, 0.0, 0.0, 0.0/)
2415  else if (ndvi >= 0.36) then
2416  co412 = (/2.94407598, 1.56448599e-02, 0.0, 0.0/)
2417  co470 = (/4.64143550, 3.94157958e-02, 5.30955969e-05, 0.0/)
2418  co650 = (/0.0, 0.0, 0.0, 0.0/)
2419  else if (ndvi >= 0.27) then
2420  co412 = (/3.55241655, 1.07045809e-02, 4.82439668e-04, 0.0/)
2421  co470 = (/5.21955006, 5.10611495e-02, 6.06966186e-04, 0.0/)
2422  co650 = (/0.0, 0.0, 0.0, 0.0/)
2423  else
2424  co412 = (/4.93773812, -6.30823250e-04, 4.83307917e-04, 0.0/)
2425  co470 = (/6.54996856, 3.14618262e-02, 2.51836348e-04, 0.0/)
2426  co650 = (/0.0, 0.0, 0.0, 0.0/)
2427  end if
2428  case default
2429  print *, "ERROR: Invalid season specified: ", season
2430  status = -1
2431  return
2432  end select
2433 
2434  else ! backward scattering
2435  select case (season)
2436  case (1)
2437  if (ndvi >= 0.54) then
2438  co412 = (/1.8666770, 0.026571400, 0.0, 0.0/)
2439  co470 = (/3.24662224, 2.49647745e-02, 0.0, 0.0/)
2440  co650 = (/0.0, 0.0, 0.0, 0.0/)
2441  else
2442  co412 = (/2.1474521, 0.019420845, 0.0, 0.0/)
2443  co470 = (/3.8045176, 0.038118250, 0.00044871309, 1.4730596e-05/)
2444  co650 = (/0.0, 0.0, 0.0, 0.0/)
2445  end if
2446  case (2)
2447  if (ndvi >= 0.54) then
2448  co412 = (/2.67001676, -1.07772899e-02, 4.98010288e-04, -7.06071474e-06/)
2449  co470 = (/3.47056999, 1.75578420e-02, 1.07148973e-04, 7.60010333e-06/)
2450  co650 = (/0.0, 0.0, 0.0, 0.0/)
2451  else if (ndvi >= 0.42) then
2452  co412 = (/3.57946117, -2.10298778e-02, -4.11579021e-04, 1.55923969e-05/)
2453  co470 = (/4.34427890, 1.57998603e-02, -5.70677301e-04, 2.11628341e-05/)
2454  co650 = (/0.0, 0.0, 0.0, 0.0/)
2455  else
2456  co412 = (/3.49153138, -1.82641547e-02, 1.71132131e-03, -2.49950954e-05/)
2457  co470 = (/4.24504494, 4.49089153e-02, 1.81406770e-03, -3.88986042e-05/)
2458  co650 = (/0.0, 0.0, 0.0, 0.0/)
2459  end if
2460  case (3)
2461  if (ndvi >= 0.36) then
2462  co412 = (/3.51804408, -5.43557298e-03, -4.11664584e-05, 4.19463147e-06/)
2463  co470 = (/4.42020622, 3.56782224e-02, 2.32453523e-04, 0.0/)
2464  co650 = (/0.0, 0.0, 0.0, 0.0/)
2465  else if (ndvi >= 0.32) then
2466  co412 = (/4.02658655, -3.41714839e-02, 1.49532934e-03, -1.20524324e-05/)
2467  co470 = (/5.29484758, 3.27714291e-02, 0.0, 0.0/)
2468  co650 = (/0.0, 0.0, 0.0, 0.0/)
2469  else if (ndvi >= 0.27) then
2470  co412 = (/4.29981928, -1.11379081e-02, 1.05046171e-03, -1.30375107e-05/)
2471  co470 = (/5.64253900, 3.74786248e-02, 5.83243337e-04, -1.00991872e-05/)
2472  co650 = (/0.0, 0.0, 0.0, 0.0/)
2473  else
2474  co412 = (/4.48791268, 2.86111924e-02, 0.0, 0.0/)
2475  co470 = (/6.24638193, 6.48367744e-02, -1.46322122e-03, 2.77197095e-05/)
2476  co650 = (/0.0, 0.0, 0.0, 0.0/)
2477  end if
2478  case (4)
2479  if (ndvi >= 0.47) then
2480  co412 = (/1.58754835, 1.20745361e-02, 0.0, 0.0/)
2481  co470 = (/2.98246568, 9.57936578e-03, 0.0, 0.0/)
2482  co650 = (/0.0, 0.0, 0.0, 0.0/)
2483  else if (ndvi >= 0.36) then
2484  co412 = (/2.94407598, 1.56448599e-02, 0.0, 0.0/)
2485  co470 = (/4.64143550, 3.94157958e-02, 5.30955969e-05, 0.0/)
2486  co650 = (/0.0, 0.0, 0.0, 0.0/)
2487  else if (ndvi >= 0.27) then
2488  co412 = (/3.55241655, 1.07045809e-02, 4.82439668e-04, 0.0/)
2489  co470 = (/5.21955006, 5.10611495e-02, 6.06966186e-04, 0.0/)
2490  co650 = (/0.0, 0.0, 0.0, 0.0/)
2491  else
2492  co412 = (/4.93773812, -6.30823250e-04, 4.83307917e-04, 0.0/)
2493  co470 = (/6.54996856, 3.14618262e-02, 2.51836348e-04, 0.0/)
2494  co650 = (/0.0, 0.0, 0.0, 0.0/)
2495  end if
2496  case default
2497  print *, "ERROR: Invalid season specified: ", season
2498  status = -1
2499  return
2500  end select
2501  end if
2502  case ("Blida")
2503  if (fwd_scat) then ! forward scattering
2504  select case (season)
2505  case (1)
2506  if (ndvi >= 0.42) then
2507  co412 = (/1.32086397, 9.43028773e-03, 6.22359822e-04, 0.0/)
2508  co470 = (/2.85239261, 3.20907415e-02, 8.29035330e-04, 0.0/)
2509  co650 = (/0.0, 0.0, 0.0, 0.0/)
2510  else
2511  co412 = (/1.36446568, 0.0, 0.0, 0.0/)
2512  co470 = (/2.92020512, -1.43458296e-02, -1.39739540e-03, 3.21024412e-05/)
2513  co650 = (/0.0, 0.0, 0.0, 0.0/)
2514  end if
2515 ! co412 = (/1.91200337, 1.88742388e-02, 0.0, 0.0/)
2516 ! co470 = (/3.51364747, 3.85886985e-02, 0.0, 0.0/)
2517 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2518  case (2)
2519  co412 = (/2.29853905, 8.40506270e-03, 4.88300278e-04, 0.0/)
2520  co470 = (/3.44064029, 3.21979141e-02, -4.24620655e-04, 2.12964306e-05/)
2521  co650 = (/0.0, 0.0, 0.0, 0.0/)
2522 ! if (ndvi >= 0.36) then
2523 ! co412 = (/2.98730763, 1.52743195e-02, 3.42813724e-04, 0.0/)
2524 ! co470 = (/4.10360363, 3.81184181e-02, -3.94054665e-04, 1.91764237e-05/)
2525 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2526 ! else
2527 ! co412 = (/3.36923597, 8.91861898e-03, 5.41011164e-04, 0.0/)
2528 ! co470 = (/4.31305027, 4.16934936e-02, 5.07485951e-04, 0.0/)
2529 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2530 ! end if
2531  case (3)
2532  if (ndvi >= 0.36) then
2533  co412 = (/3.51804408, -5.43557298e-03, -4.11664584e-05, 4.19463147e-06/)
2534  co470 = (/4.42020622, 3.56782224e-02, 2.32453523e-04, 0.0/)
2535  co650 = (/0.0, 0.0, 0.0, 0.0/)
2536  else if (ndvi >= 0.30) then
2537  co412 = (/4.02658655, -3.41714839e-02, 1.49532934e-03, -1.20524324e-05/)
2538  co470 = (/5.29484758, 3.27714291e-02, 0.0, 0.0/)
2539  co650 = (/0.0, 0.0, 0.0, 0.0/)
2540  else
2541  co412 = (/4.29981928, -1.11379081e-02, 1.05046171e-03, -1.30375107e-05/)
2542  co470 = (/5.64253900, 3.74786248e-02, 5.83243337e-04, -1.00991872e-05/)
2543  co650 = (/0.0, 0.0, 0.0, 0.0/)
2544  end if
2545 ! if (ndvi >= 0.27) then
2546 ! co412 = (/4.14926099, 1.42958399e-03, 4.64133459e-04, 0.0/)
2547 ! co470 = (/5.02372861, 4.57270649e-02, -5.17735411e-05, 4.71527134e-06/)
2548 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2549 ! else
2550 ! co412 = (/4.13229478, 2.66646676e-02, 0.0, 0.0/)
2551 ! co470 = (/5.01590910, 6.48840906e-02, 0.0, 0.0/)
2552 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2553 ! end if
2554  case (4)
2555  if (ndvi >= 0.36) then
2556  co412 = (/1.31986294, -1.07513582e-02, 4.65319050e-04, 2.35774710e-05/)
2557  co470 = (/3.03892353, 2.84719270e-02, 4.80364309e-04, 2.19066757e-05/)
2558  co650 = (/0.0, 0.0, 0.0, 0.0/)
2559  else
2560  co412 = (/2.18453166, 3.51533148e-02, 0.0, 0.0/)
2561  co470 = (/3.68111291, 5.65877577e-02, 0.0, 0.0/)
2562  co650 = (/0.0, 0.0, 0.0, 0.0/)
2563  end if
2564 ! if (ndvi >= 0.27) then
2565 ! co412 = (/2.21833952, 1.02488472e-02, 0.0, 0.0/)
2566 ! co470 = (/4.01205578, 4.26871364e-02, -3.01909029e-05, 0.0/)
2567 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2568 ! else
2569 ! co412 = (/3.84250107, 3.15218358e-02, 0.0, 0.0/)
2570 ! co470 = (/5.07606928, 5.52702453e-02, 1.11978961e-04, 0.0/)
2571 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2572 ! end if
2573  case default
2574  print *, "ERROR: Invalid season specified: ", season
2575  status = -1
2576  return
2577  end select
2578 
2579  else ! backward scattering
2580  select case (season)
2581  case (1)
2582  if (ndvi >= 0.42) then
2583  co412 = (/1.32086397, 9.43028773e-03, 6.22359822e-04, 0.0/)
2584  co470 = (/2.85239261, 3.20907415e-02, 8.29035330e-04, 0.0/)
2585  co650 = (/0.0, 0.0, 0.0, 0.0/)
2586  else
2587  co412 = (/1.36446568, 0.0, 0.0, 0.0/)
2588  co470 = (/2.92020512, -1.43458296e-02, -1.39739540e-03, 3.21024412e-05/)
2589  co650 = (/0.0, 0.0, 0.0, 0.0/)
2590  end if
2591 ! co412 = (/1.91200337, 1.88742388e-02, 0.0, 0.0/)
2592 ! co470 = (/3.51364747, 3.85886985e-02, 0.0, 0.0/)
2593 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2594  case (2)
2595  co412 = (/2.29853905, 8.40506270e-03, 4.88300278e-04, 0.0/)
2596  co470 = (/3.44064029, 3.21979141e-02, -4.24620655e-04, 2.12964306e-05/)
2597  co650 = (/0.0, 0.0, 0.0, 0.0/)
2598 ! if (ndvi >= 0.36) then
2599 ! co412 = (/2.98730763, 1.52743195e-02, 3.42813724e-04, 0.0/)
2600 ! co470 = (/4.10360363, 3.81184181e-02, -3.94054665e-04, 1.91764237e-05/)
2601 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2602 ! else
2603 ! co412 = (/3.36923597, 8.91861898e-03, 5.41011164e-04, 0.0/)
2604 ! co470 = (/4.31305027, 4.16934936e-02, 5.07485951e-04, 0.0/)
2605 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2606 ! end if
2607  case (3)
2608  if (ndvi >= 0.36) then
2609  co412 = (/3.51804408, -5.43557298e-03, -4.11664584e-05, 4.19463147e-06/)
2610  co470 = (/4.42020622, 3.56782224e-02, 2.32453523e-04, 0.0/)
2611  co650 = (/0.0, 0.0, 0.0, 0.0/)
2612  else if (ndvi >= 0.30) then
2613  co412 = (/4.02658655, -3.41714839e-02, 1.49532934e-03, -1.20524324e-05/)
2614  co470 = (/5.29484758, 3.27714291e-02, 0.0, 0.0/)
2615  co650 = (/0.0, 0.0, 0.0, 0.0/)
2616  else
2617  co412 = (/4.29981928, -1.11379081e-02, 1.05046171e-03, -1.30375107e-05/)
2618  co470 = (/5.64253900, 3.74786248e-02, 5.83243337e-04, -1.00991872e-05/)
2619  co650 = (/0.0, 0.0, 0.0, 0.0/)
2620  end if
2621 ! if (ndvi >= 0.27) then
2622 ! co412 = (/4.14926099, 1.42958399e-03, 4.64133459e-04, 0.0/)
2623 ! co470 = (/5.02372861, 4.57270649e-02, -5.17735411e-05, 4.71527134e-06/)
2624 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2625 ! else
2626 ! co412 = (/4.13229478, 2.66646676e-02, 0.0, 0.0/)
2627 ! co470 = (/5.01590910, 6.48840906e-02, 0.0, 0.0/)
2628 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2629 ! end if
2630  case (4)
2631  if (ndvi >= 0.36) then
2632  co412 = (/1.31986294, -1.07513582e-02, 4.65319050e-04, 2.35774710e-05/)
2633  co470 = (/3.03892353, 2.84719270e-02, 4.80364309e-04, 2.19066757e-05/)
2634  co650 = (/0.0, 0.0, 0.0, 0.0/)
2635  else
2636  co412 = (/2.18453166, 3.51533148e-02, 0.0, 0.0/)
2637  co470 = (/3.68111291, 5.65877577e-02, 0.0, 0.0/)
2638  co650 = (/0.0, 0.0, 0.0, 0.0/)
2639  end if
2640 ! if (ndvi >= 0.27) then
2641 ! co412 = (/2.21833952, 1.02488472e-02, 0.0, 0.0/)
2642 ! co470 = (/4.01205578, 4.26871364e-02, -3.01909029e-05, 0.0/)
2643 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2644 ! else
2645 ! co412 = (/3.84250107, 3.15218358e-02, 0.0, 0.0/)
2646 ! co470 = (/5.07606928, 5.52702453e-02, 1.11978961e-04, 0.0/)
2647 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2648 ! end if
2649  case default
2650  print *, "ERROR: Invalid season specified: ", season
2651  status = -1
2652  return
2653  end select
2654  end if
2655  case ("Blida_High")
2656  if (fwd_scat) then ! forward scattering
2657  select case (season)
2658  case (1)
2659  if (ndvi >= 0.42) then
2660  co412 = (/1.32086397, 9.43028773e-03, 6.22359822e-04, 0.0/)
2661  co470 = (/2.85239261, 3.20907415e-02, 8.29035330e-04, 0.0/)
2662  co650 = (/0.0, 0.0, 0.0, 0.0/)
2663  else
2664  co412 = (/1.36446568, 0.0, 0.0, 0.0/)
2665  co470 = (/2.92020512, -1.43458296e-02, -1.39739540e-03, 3.21024412e-05/)
2666  co650 = (/0.0, 0.0, 0.0, 0.0/)
2667  end if
2668 ! co412 = (/1.91200337, 1.88742388e-02, 0.0, 0.0/)
2669 ! co470 = (/3.51364747, 3.85886985e-02, 0.0, 0.0/)
2670 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2671  case (2)
2672  co412 = (/2.29853905, 8.40506270e-03, 4.88300278e-04, 0.0/)
2673  co470 = (/3.44064029, 3.21979141e-02, -4.24620655e-04, 2.12964306e-05/)
2674  co650 = (/0.0, 0.0, 0.0, 0.0/)
2675 ! if (ndvi >= 0.36) then
2676 ! co412 = (/2.98730763, 1.52743195e-02, 3.42813724e-04, 0.0/)
2677 ! co470 = (/4.10360363, 3.81184181e-02, -3.94054665e-04, 1.91764237e-05/)
2678 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2679 ! else
2680 ! co412 = (/3.36923597, 8.91861898e-03, 5.41011164e-04, 0.0/)
2681 ! co470 = (/4.31305027, 4.16934936e-02, 5.07485951e-04, 0.0/)
2682 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2683 ! end if
2684  case (3)
2685  if (ndvi >= 0.36) then
2686  co412 = (/3.51804408, -5.43557298e-03, -4.11664584e-05, 4.19463147e-06/)
2687  co470 = (/4.42020622, 3.56782224e-02, 2.32453523e-04, 0.0/)
2688  co650 = (/0.0, 0.0, 0.0, 0.0/)
2689  else if (ndvi >= 0.30) then
2690  co412 = (/4.02658655, -3.41714839e-02, 1.49532934e-03, -1.20524324e-05/)
2691  co470 = (/5.29484758, 3.27714291e-02, 0.0, 0.0/)
2692  co650 = (/0.0, 0.0, 0.0, 0.0/)
2693  else
2694  co412 = (/4.29981928, -1.11379081e-02, 1.05046171e-03, -1.30375107e-05/)
2695  co470 = (/5.64253900, 3.74786248e-02, 5.83243337e-04, -1.00991872e-05/)
2696  co650 = (/0.0, 0.0, 0.0, 0.0/)
2697  end if
2698 ! if (ndvi >= 0.27) then
2699 ! co412 = (/4.14926099, 1.42958399e-03, 4.64133459e-04, 0.0/)
2700 ! co470 = (/5.02372861, 4.57270649e-02, -5.17735411e-05, 4.71527134e-06/)
2701 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2702 ! else
2703 ! co412 = (/4.13229478, 2.66646676e-02, 0.0, 0.0/)
2704 ! co470 = (/5.01590910, 6.48840906e-02, 0.0, 0.0/)
2705 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2706 ! end if
2707  case (4)
2708  if (ndvi >= 0.36) then
2709  co412 = (/1.31986294, -1.07513582e-02, 4.65319050e-04, 2.35774710e-05/)
2710  co470 = (/3.03892353, 2.84719270e-02, 4.80364309e-04, 2.19066757e-05/)
2711  co650 = (/0.0, 0.0, 0.0, 0.0/)
2712  else
2713  co412 = (/2.18453166, 3.51533148e-02, 0.0, 0.0/)
2714  co470 = (/3.68111291, 5.65877577e-02, 0.0, 0.0/)
2715  co650 = (/0.0, 0.0, 0.0, 0.0/)
2716  end if
2717 ! if (ndvi >= 0.27) then
2718 ! co412 = (/2.21833952, 1.02488472e-02, 0.0, 0.0/)
2719 ! co470 = (/4.01205578, 4.26871364e-02, -3.01909029e-05, 0.0/)
2720 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2721 ! else
2722 ! co412 = (/3.84250107, 3.15218358e-02, 0.0, 0.0/)
2723 ! co470 = (/5.07606928, 5.52702453e-02, 1.11978961e-04, 0.0/)
2724 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2725 ! end if
2726  case default
2727  print *, "ERROR: Invalid season specified: ", season
2728  status = -1
2729  return
2730  end select
2731 
2732  else ! backward scattering
2733  select case (season)
2734  case (1)
2735  if (ndvi >= 0.42) then
2736  co412 = (/1.32086397, 9.43028773e-03, 6.22359822e-04, 0.0/)
2737  co470 = (/2.85239261, 3.20907415e-02, 8.29035330e-04, 0.0/)
2738  co650 = (/0.0, 0.0, 0.0, 0.0/)
2739  else
2740  co412 = (/1.36446568, 0.0, 0.0, 0.0/)
2741  co470 = (/2.92020512, -1.43458296e-02, -1.39739540e-03, 3.21024412e-05/)
2742  co650 = (/0.0, 0.0, 0.0, 0.0/)
2743  end if
2744 ! co412 = (/1.91200337, 1.88742388e-02, 0.0, 0.0/)
2745 ! co470 = (/3.51364747, 3.85886985e-02, 0.0, 0.0/)
2746 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2747  case (2)
2748  co412 = (/2.29853905, 8.40506270e-03, 4.88300278e-04, 0.0/)
2749  co470 = (/3.44064029, 3.21979141e-02, -4.24620655e-04, 2.12964306e-05/)
2750  co650 = (/0.0, 0.0, 0.0, 0.0/)
2751 ! if (ndvi >= 0.36) then
2752 ! co412 = (/2.98730763, 1.52743195e-02, 3.42813724e-04, 0.0/)
2753 ! co470 = (/4.10360363, 3.81184181e-02, -3.94054665e-04, 1.91764237e-05/)
2754 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2755 ! else
2756 ! co412 = (/3.36923597, 8.91861898e-03, 5.41011164e-04, 0.0/)
2757 ! co470 = (/4.31305027, 4.16934936e-02, 5.07485951e-04, 0.0/)
2758 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2759 ! end if
2760  case (3)
2761  if (ndvi >= 0.36) then
2762  co412 = (/3.51804408, -5.43557298e-03, -4.11664584e-05, 4.19463147e-06/)
2763  co470 = (/4.42020622, 3.56782224e-02, 2.32453523e-04, 0.0/)
2764  co650 = (/0.0, 0.0, 0.0, 0.0/)
2765  else if (ndvi >= 0.30) then
2766  co412 = (/4.02658655, -3.41714839e-02, 1.49532934e-03, -1.20524324e-05/)
2767  co470 = (/5.29484758, 3.27714291e-02, 0.0, 0.0/)
2768  co650 = (/0.0, 0.0, 0.0, 0.0/)
2769  else
2770  co412 = (/4.29981928, -1.11379081e-02, 1.05046171e-03, -1.30375107e-05/)
2771  co470 = (/5.64253900, 3.74786248e-02, 5.83243337e-04, -1.00991872e-05/)
2772  co650 = (/0.0, 0.0, 0.0, 0.0/)
2773  end if
2774 ! if (ndvi >= 0.27) then
2775 ! co412 = (/4.14926099, 1.42958399e-03, 4.64133459e-04, 0.0/)
2776 ! co470 = (/5.02372861, 4.57270649e-02, -5.17735411e-05, 4.71527134e-06/)
2777 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2778 ! else
2779 ! co412 = (/4.13229478, 2.66646676e-02, 0.0, 0.0/)
2780 ! co470 = (/5.01590910, 6.48840906e-02, 0.0, 0.0/)
2781 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2782 ! end if
2783  case (4)
2784  if (ndvi >= 0.36) then
2785  co412 = (/1.31986294, -1.07513582e-02, 4.65319050e-04, 2.35774710e-05/)
2786  co470 = (/3.03892353, 2.84719270e-02, 4.80364309e-04, 2.19066757e-05/)
2787  co650 = (/0.0, 0.0, 0.0, 0.0/)
2788  else
2789  co412 = (/2.18453166, 3.51533148e-02, 0.0, 0.0/)
2790  co470 = (/3.68111291, 5.65877577e-02, 0.0, 0.0/)
2791  co650 = (/0.0, 0.0, 0.0, 0.0/)
2792  end if
2793 ! if (ndvi >= 0.27) then
2794 ! co412 = (/2.21833952, 1.02488472e-02, 0.0, 0.0/)
2795 ! co470 = (/4.01205578, 4.26871364e-02, -3.01909029e-05, 0.0/)
2796 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2797 ! else
2798 ! co412 = (/3.84250107, 3.15218358e-02, 0.0, 0.0/)
2799 ! co470 = (/5.07606928, 5.52702453e-02, 1.11978961e-04, 0.0/)
2800 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2801 ! end if
2802  case default
2803  print *, "ERROR: Invalid season specified: ", season
2804  status = -1
2805  return
2806  end select
2807  end if
2808  case ("Ilorin")
2809  select case (season)
2810  case (1)
2811 ! if (ndvi >= 0.24) then
2812  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2813  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2814  co650 = (/0.0, 0.0, 0.0, 0.0/)
2815 ! else
2816 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2817 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2818 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2819 ! end if
2820  case (2)
2821 ! if (ndvi >= 0.24) then
2822 ! co412 = (/4.95397318, 1.73386252E-02, -3.19877587E-04, 4.02574564E-06/)
2823 ! co470 = (/6.76241404, 5.21461588E-02, -4.94776417E-04, 5.45084985E-06/)
2824 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2825  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2826  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2827  co650 = (/0.0, 0.0, 0.0, 0.0/)
2828 ! else
2829 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2830 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2831 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2832 ! end if
2833  case (3)
2834 ! if (ndvi >= 0.24) then
2835 ! co412 = (/4.95397318, 1.73386252E-02, -3.19877587E-04, 4.02574564E-06/)
2836 ! co470 = (/6.76241404, 5.21461588E-02, -4.94776417E-04, 5.45084985E-06/)
2837 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2838  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2839  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2840  co650 = (/0.0, 0.0, 0.0, 0.0/)
2841 ! else
2842 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2843 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2844 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2845 ! end if
2846  case (4)
2847 ! if (ndvi >= 0.24) then
2848 ! co412 = (/4.95397318, 1.73386252E-02, -3.19877587E-04, 4.02574564E-06/)
2849 ! co470 = (/6.76241404, 5.21461588E-02, -4.94776417E-04, 5.45084985E-06/)
2850 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2851  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2852  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2853  co650 = (/0.0, 0.0, 0.0, 0.0/)
2854 ! else
2855 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2856 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2857 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2858 ! end if
2859  case default
2860  print *, "ERROR: Invalid season specified: ", season
2861  status = -1
2862  return
2863  end select
2864  case ("Ilorin_Transition")
2865  select case (season)
2866  case (1)
2867 ! if (ndvi >= 0.24) then
2868  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2869  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2870  co650 = (/0.0, 0.0, 0.0, 0.0/)
2871 ! else
2872 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2873 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2874 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2875 ! end if
2876  case (2)
2877 ! if (ndvi >= 0.24) then
2878 ! co412 = (/4.95397318, 1.73386252E-02, -3.19877587E-04, 4.02574564E-06/)
2879 ! co470 = (/6.76241404, 5.21461588E-02, -4.94776417E-04, 5.45084985E-06/)
2880 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2881  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2882  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2883  co650 = (/0.0, 0.0, 0.0, 0.0/)
2884 ! else
2885 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2886 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2887 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2888 ! end if
2889  case (3)
2890 ! if (ndvi >= 0.24) then
2891 ! co412 = (/4.95397318, 1.73386252E-02, -3.19877587E-04, 4.02574564E-06/)
2892 ! co470 = (/6.76241404, 5.21461588E-02, -4.94776417E-04, 5.45084985E-06/)
2893 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2894  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2895  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2896  co650 = (/0.0, 0.0, 0.0, 0.0/)
2897 ! else
2898 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2899 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2900 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2901 ! end if
2902  case (4)
2903 ! if (ndvi >= 0.24) then
2904 ! co412 = (/4.95397318, 1.73386252E-02, -3.19877587E-04, 4.02574564E-06/)
2905 ! co470 = (/6.76241404, 5.21461588E-02, -4.94776417E-04, 5.45084985E-06/)
2906 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2907  co412 = (/1.95397318, 1.73386252e-02, -3.19877587e-04, 4.02574564e-06/)
2908  co470 = (/2.76241404, 5.21461588e-02, -4.94776417e-04, 5.45084985e-06/)
2909  co650 = (/0.0, 0.0, 0.0, 0.0/)
2910 ! else
2911 ! co412 = (/4.97022734, 1.39816544E-02, -6.20379323E-06, 4.10908585E-06/)
2912 ! co470 = (/7.51990477, 5.62140108E-02, -2.65648653E-04, 0.0/)
2913 ! co650 = (/0.0, 0.0, 0.0, 0.0/)
2914 ! end if
2915  case default
2916  print *, "ERROR: Invalid season specified: ", season
2917  status = -1
2918  return
2919  end select
2920 
2921  case ("SACOL")
2922  select case (season)
2923  case (1)
2924  co412 = (/1.42564317, 0.0, 0.0, 0.0/)
2925  co470 = (/5.32085036, 7.76166789e-02, 0.0, 0.0/)
2926  co650 = (/0.0, 0.0, 0.0, 0.0/)
2927  case (2)
2928  if (ndvi < 0.22) then
2929  co412 = (/2.56745262, 3.14455912e-02, 0.0, 0.0/)
2930  co470 = (/5.72543787, 6.57833956e-02, 0.0, 0.0/)
2931  co650 = (/0.0, 0.0, 0.0, 0.0/)
2932  else
2933  co412 = (/2.98578012, 9.14981794e-03, 2.78390281e-05, 0.0/)
2934  co470 = (/5.35045898, 5.95767492e-02, -2.40088902e-04, 0.0/)
2935  co650 = (/0.0, 0.0, 0.0, 0.0/)
2936  end if
2937  case (3)
2938  if (ndvi < 0.32) then
2939  co412 = (/3.09389618, 3.43945319e-02, -1.73503979e-04, 0.0/)
2940  co470 = (/5.26831030, 7.26053989e-02, -4.36121233e-04, 0.0/)
2941  co650 = (/0.0, 0.0, 0.0, 0.0/)
2942  else if (ndvi >= 0.32 .AND. ndvi < 0.38) then
2943  co412 = (/2.29526550, -2.85560957e-02, 1.16556608e-03, 0.0/)
2944  co470 = (/4.35768768, 2.04838826e-02, 7.12226936e-04, 0.0/)
2945  co650 = (/0.0, 0.0, 0.0, 0.0/)
2946  else
2947  co412 = (/2.57989638, 3.85962492e-02, -1.23228526e-03, 0.0/)
2948  co470 = (/4.19697042, 6.43432125e-02, -1.15802337e-03, 0.0/)
2949  co650 = (/0.0, 0.0, 0.0, 0.0/)
2950  end if
2951  case (4)
2952  if (ndvi < 0.20) then
2953  co412 = (/7.26239004e-01, 1.6566520e-02, 0.0, 0.0/)
2954  co470 = (/5.08897915, 2.07599476e-02, -1.86393057e-03, 2.40076652e-05/)
2955  co650 = (/0.0, 0.0, 0.0, 0.0/)
2956  else if (ndvi >= 0.2 .AND. ndvi < 0.3) then
2957  co412 = (/1.45776255, 7.95302789e-03, 0.0, 0.0/)
2958  co470 = (/4.23968258, 4.32695605e-02, 0.0, 0.0/)
2959  co650 = (/0.0, 0.0, 0.0, 0.0/)
2960  else
2961  co412 = (/1.01734497, 0.0, 0.0, 0.0/)
2962  co470 = (/3.58458577, 4.92096024e-02, -1.69568606e-04, 0.0/)
2963  co650 = (/0.0, 0.0, 0.0, 0.0/)
2964  end if
2965  case default
2966  print *, "ERROR: Invalid season specified: ", season
2967  status = -1
2968  return
2969  end select
2970 
2971  case ("Mexico_City")
2972  select case (season)
2973  case (1)
2974  co412 = (/1.5925121, 3.3497126e-3, 5.2599315e-4, 0.0/)
2975  co470 = (/5.1297925, 2.8796298e-2, 1.3826814e-3, 0.0/)
2976  co650 = (/0.0, 0.0, 0.0, 0.0/)
2977 
2978  case (2)
2979  co412 = (/2.0907425, -9.7213367e-3, 5.6728594e-4, 0.0/)
2980  co470 = (/5.4475574, 4.8689334e-2, 1.3585394e-4, 0.0/)
2981  co650 = (/0.0, 0.0, 0.0, 0.0/)
2982 
2983  case (3)
2984  if (ndvi < 0.2) then
2985  co412 = (/1.31131496, 1.90175933e-02, 0.0, 0.0/)
2986  co470 = (/4.28780511, 4.85799304e-02, 1.65298184e-03, 0.0/)
2987  co650 = (/0.0, 0.0, 0.0, 0.0/)
2988  else
2989  co412 = (/3.19067520, 2.81951590e-02, 0.0, 0.0/)
2990  co470 = (/3.14833814, 1.05654939e-01, 0.0, 0.0/)
2991  co650 = (/0.0, 0.0, 0.0, 0.0/)
2992  end if
2993 
2994  case (4)
2995  co412 = (/1.8093284, -9.0862879e-4, 2.2399699e-4, 0.0/)
2996  co470 = (/5.1765348, 3.8358608e-2, 9.4711253e-4, 0.0/)
2997  co650 = (/0.0, 0.0, 0.0, 0.0/)
2998 
2999  case default
3000  print *, "ERROR: Invalid season specified: ", season
3001  status = -1
3002  return
3003  end select
3004 
3005  case ("Jaipur")
3006  select case (season)
3007  case (1)
3008  if (ndvi < 0.2) then
3009  co412 = (/3.96991225, 5.96628950e-02, 2.13615454e-04, 0.0/)
3010  co470 = (/6.99850585, 8.36445599e-02, -1.10860486e-04, 6.74081297e-06/)
3011  co650 = (/0.0, 0.0, 0.0, 0.0/)
3012  else if (ndvi < 0.25) then
3013  co412 = (/3.833049805, 4.78326202e-02, -6.22253363e-04, 0.0/)
3014  co470 = (/6.31127139, 6.19777232e-02, -1.56997452e-04, 2.82474197e-05/)
3015  co650 = (/0.0, 0.0, 0.0, 0.0/)
3016  else
3017  co412 = (/4.66180293, 2.20314064e-02, 5.87633091e-04, -4.13864227e-06/)
3018  co470 = (/6.57270431, 5.7747869e-02, 7.34838329e-06, 0.0/)
3019  co650 = (/0.0, 0.0, 0.0, 0.0/)
3020  end if
3021 
3022  case (2)
3023  if (ndvi < 0.18) then
3024  co412 = (/4.20196229, 5.29500002e-02, 3.20204802e-04, 0.0/)
3025  co470 = (/7.22026945, 9.03690963e-02, 0.0, 0.0/)
3026  co650 = (/0.0, 0.0, 0.0, 0.0/)
3027  else
3028  co412 = (/4.65595362, 7.51832486e-02, -1.85215442e-03, 2.82980108e-05/)
3029  co470 = (/7.06658854, 8.85016889e-02, -8.29003477e-04, 1.30125894e-05/)
3030  co650 = (/0.0, 0.0, 0.0, 0.0/)
3031  end if
3032  case (3)
3033  if (ndvi < 0.2) then
3034  co412 = (/4.28651135, 9.9311289e-02, -5.34064043e-04, 0.0/)
3035  co470 = (/7.49201557, 1.37003165e-01, -1.41178674e-03, 8.95252657e-06/)
3036  co650 = (/0.0, 0.0, 0.0, 0.0/)
3037  else
3038  co412 = (/7.02860038, -4.65828642e-03, 0.0, 0.0/)
3039  co470 = (/7.89866675, 2.63625768e-02, 0.0, 0.0/)
3040  co650 = (/0.0, 0.0, 0.0, 0.0/)
3041  end if
3042 
3043  case (4)
3044  if (ndvi < 0.22) then
3045  co412 = (/2.82799186, 3.51207193e-02, 0.0, 0.0/)
3046  co470 = (/6.03474644, 6.89646847e-02, 3.96325172e-04, 0.0/)
3047  co650 = (/0.0, 0.0, 0.0, 0.0/)
3048  else if (ndvi < 0.25) then
3049  co412 = (/3.52929901, 5.18358835e-02, 0.0, 0.0/)
3050  co470 = (/5.94045545, 7.50816643e-02, 6.01703567e-04, -4.63811122e-06/)
3051  co650 = (/0.0, 0.0, 0.0, 0.0/)
3052  else
3053  co412 = (/4.70013291, 2.23865261e-02, -2.10276745e-05, 1.11426756e-05/)
3054  co470 = (/6.46922757, 3.76858031e-02, 7.48824729e-04, 0.0/)
3055  co650 = (/0.0, 0.0, 0.0, 0.0/)
3056  end if
3057  case default
3058  print *, "ERROR: Invalid season specified: ", season
3059  status = -1
3060  return
3061  end select
3062 
3063  case ("NW_India_Desert")
3064  select case (season)
3065  case (1)
3066  if (ndvi < 0.2) then
3067  co412 = (/3.96991225, 5.96628950e-02, 2.13615454e-04, 0.0/)
3068  co470 = (/6.99850585, 8.36445599e-02, -1.10860486e-04, 6.74081297e-06/)
3069  co650 = (/0.0, 0.0, 0.0, 0.0/)
3070  else if (ndvi < 0.25) then
3071  co412 = (/3.833049805, 4.78326202e-02, -6.22253363e-04, 0.0/)
3072  co470 = (/6.31127139, 6.19777232e-02, -1.56997452e-04, 2.82474197e-05/)
3073  co650 = (/0.0, 0.0, 0.0, 0.0/)
3074  else
3075  co412 = (/4.66180293, 2.20314064e-02, 5.87633091e-04, -4.13864227e-06/)
3076  co470 = (/6.57270431, 5.7747869e-02, 7.34838329e-06, 0.0/)
3077  co650 = (/0.0, 0.0, 0.0, 0.0/)
3078  end if
3079 
3080  case (2)
3081  if (ndvi < 0.18) then
3082  co412 = (/4.20196229, 5.29500002e-02, 3.20204802e-04, 0.0/)
3083  co470 = (/7.22026945, 9.03690963e-02, 0.0, 0.0/)
3084  co650 = (/0.0, 0.0, 0.0, 0.0/)
3085  else
3086  co412 = (/4.65595362, 7.51832486e-02, -1.85215442e-03, 2.82980108e-05/)
3087  co470 = (/7.06658854, 8.85016889e-02, -8.29003477e-04, 1.30125894e-05/)
3088  co650 = (/0.0, 0.0, 0.0, 0.0/)
3089  end if
3090  case (3)
3091  if (ndvi < 0.2) then
3092  co412 = (/4.28651135, 9.9311289e-02, -5.34064043e-04, 0.0/)
3093  co470 = (/7.49201557, 1.37003165e-01, -1.41178674e-03, 8.95252657e-06/)
3094  co650 = (/0.0, 0.0, 0.0, 0.0/)
3095  else
3096  co412 = (/7.02860038, -4.65828642e-03, 0.0, 0.0/)
3097  co470 = (/7.89866675, 2.63625768e-02, 0.0, 0.0/)
3098  co650 = (/0.0, 0.0, 0.0, 0.0/)
3099  end if
3100 
3101  case (4)
3102  if (ndvi < 0.22) then
3103  co412 = (/2.82799186, 3.51207193e-02, 0.0, 0.0/)
3104  co470 = (/6.03474644, 6.89646847e-02, 3.96325172e-04, 0.0/)
3105  co650 = (/0.0, 0.0, 0.0, 0.0/)
3106  else if (ndvi < 0.25) then
3107  co412 = (/3.52929901, 5.18358835e-02, 0.0, 0.0/)
3108  co470 = (/5.94045545, 7.50816643e-02, 6.01703567e-04, -4.63811122e-06/)
3109  co650 = (/0.0, 0.0, 0.0, 0.0/)
3110  else
3111  co412 = (/4.70013291, 2.23865261e-02, -2.10276745e-05, 1.11426756e-05/)
3112  co470 = (/6.46922757, 3.76858031e-02, 7.48824729e-04, 0.0/)
3113  co650 = (/0.0, 0.0, 0.0, 0.0/)
3114  end if
3115  case default
3116  print *, "ERROR: Invalid season specified: ", season
3117  status = -1
3118  return
3119  end select
3120 
3121  case ("Solar_Village")
3122  select case (season)
3123  case (1)
3124  co412 = (/9.57450477, 6.14694128e-02, 0.0, 0.0/)
3125  if (vza < 20.0) then
3126  co470 = (/1.60353001e01, 1.10436421e-02, 7.06173197e-04, 0.0/)
3127  else if (vza < 50.0) then
3128  co470 = (/1.50683392e01, 9.11896309e-02, 8.77940132e-04, -2.02723278e-05/)
3129  else
3130  co470 = (/1.58007075e01, 1.11295620e-01, 0.0, 0.0/)
3131  end if
3132  co650 = (/0.0, 0.0, 0.0, 0.0/)
3133 
3134  case (2)
3135  co412 = (/8.74736445, 6.51554815e-02, 0.0, 0.0/)
3136  co470 = (/1.53111360e01, 1.05595037e-01, -7.31500339e-04, 0.0/)
3137  co650 = (/0.0, 0.0, 0.0, 0.0/)
3138 
3139  if (raa < 50.0) then
3140  co412 = (/8.63300701, 1.29057864e-01, -2.95916295e-03, 1.83110100e-05/)
3141  co470 = (/1.46695788e01, 9.60421930e-02, -2.40220378e-03, 2.99138049e-05/)
3142  co650 = (/0.0, 0.0, 0.0, 0.0/)
3143  else if (raa >= 50.0 .AND. raa < 90.0) then
3144  co412 = (/1.01609630e01, 1.02434047e-01, -1.36452416e-03, 0.0/)
3145  co470 = (/1.51255831e01, 7.36233156e-02, 4.74327855e-04, 0.0/)
3146  co650 = (/0.0, 0.0, 0.0, 0.0/)
3147  else if (raa >= 90.0 .AND. raa < 160.0) then
3148  co412 = (/1.09242704e01, 0.0, 0.0, 0.0/)
3149  co470 = (/1.95602923e01, -5.44866657e-02, 0.0, 0.0/)
3150  co650 = (/0.0, 0.0, 0.0, 0.0/)
3151  else
3152  co412 = (/7.76882726, 7.90204491e-02, 0.0, 0.0/)
3153  co470 = (/1.65201198e01, 3.67393757e-02, 0.0, 0.0/)
3154  co650 = (/0.0, 0.0, 0.0, 0.0/)
3155  end if
3156 
3157  case (3)
3158  co412 = (/9.22657792, 5.53831366e-02, 0.0, 0.0/)
3159  if (vza < 25.0) then
3160  co470 = (/1.39265362e01, 9.32481786e-02, 0.0, 0.0/)
3161  else if (vza < 45.0) then
3162  co470 = (/1.47453243e01, 9.60301995e-02, 0.0, 0.0/)
3163  else
3164  co470 = (/1.54562369e01, 9.40036429e-02, 0.0, 0.0/)
3165  endif
3166 
3167  co412 = (/8.9590389, 0.017604729, 0.00076547611, -2.1966118e-06/)
3168  co470 = (/14.904570, 0.053656442, 0.0010690852, -1.8405743e-05/)
3169  co650 = (/0.0, 0.0, 0.0, 0.0/)
3170 
3171  if (raa < 90.0) then
3172  co412 = (/9.1177595, 0.039785655, -0.00062878201, 2.1237891e-05/)
3173  co470 = (/14.843738, 0.024588279, 0.00021114164, 1.2466120e-05/)
3174  co650 = (/0.0, 0.0, 0.0, 0.0/)
3175  else
3176  co412 = (/7.55891171, 8.05857229e-02, 0.0, 0.0/)
3177  co470 = (/1.66963898e01, 1.07268522e-02, 2.79875503e-04, 0.0/)
3178  co650 = (/0.0, 0.0, 0.0, 0.0/)
3179  end if
3180  case (4)
3181  co412 = (/9.81027873, 5.79203714e-02, 0.0, 0.0/)
3182  if (vza < 25.0) then
3183  co470 = (/1.50017355e01, 8.33530298e-02, 0.0, 0.0/)
3184  else if (vza < 50.0) then
3185  co470 = (/1.54093325e01, 9.33699483e-02, -8.75858189e-05, 1.76518228e-05/)
3186  else
3187  co470 = (/1.63141003e10, 1.14528713e-01, 0.0, 0.0/)
3188  end if
3189 
3190  case default
3191  print *, "ERROR: Invalid season specified: ", season
3192  status = -1
3193  return
3194  end select
3195 
3196  case ("Yuma")
3197  select case (season)
3198  case (1)
3199  co412 = (/8.88808, 4.0613965e-2, 1.1960322e-3, 0.0/)
3200  co470 = (/10.78728, 6.864285e-2, 1.15425508e-3, 0.0/)
3201  co650 = (/0.0, 0.0, 0.0, 0.0/)
3202 
3203  case (2)
3204  co412 = (/8.7442283, 2.53485488e-2, 4.54854215e-4,0.0/)
3205  co470 = (/10.872899, 5.6826757e-2, 1.35925198e-4, 0.0/)
3206  co650 = (/0.0, 0.0, 0.0, 0.0/)
3207 
3208  case (3)
3209  co412 = (/8.7692651, 3.3495399e-2, 3.7264769e-4,0.0/)
3210  co470 = (/10.92206559, 5.96282369e-2, 2.79797715e-4, 0.0/)
3211  co650 = (/0.0, 0.0, 0.0, 0.0/)
3212 
3213  case (4)
3214  co412 = (/8.9693997, 3.65029508e-2, 6.62722818e-4,0.0/)
3215  co470 = (/11.0841727, 5.91805818e-2, 7.60347456e-4, 0.0/)
3216  co650 = (/0.0, 0.0, 0.0, 0.0/)
3217 
3218  case default
3219  print *, "ERROR: Invalid season specified: ", season
3220  status = -1
3221  return
3222  end select
3223 
3224  case default
3225  print *, "ERROR: Invalid AERONET site specified. No BRDF values."
3226  status = -1
3227  return
3228  end select
3229 
3230 ! -- coefficients above were calculated using (sca-120) rather than sca. Must do same here.
3231  s412 = co412(1) + co412(2)*(sca-120.0) + co412(3)*((sca-120.0)**2) + co412(4)*((sca-120.0)**3)
3232  s470 = co470(1) + co470(2)*(sca-120.0) + co470(3)*((sca-120.0)**2) + co470(4)*((sca-120.0)**3)
3233  s650 = co650(1) + co650(2)*(sca-120.0) + co650(3)*((sca-120.0)**2) + co650(4)*((sca-120.0)**3)
3234 
3235  c412 = co412(1)
3236  c470 = co470(1)
3237  c650 = co650(1)
3238 
3239  if (dflag) then
3240  print '(A,A,A,I4,I4,2(F11.6,1X))', trim(func_name), ", site, month, season, ndvi, scat: ", &
3241  & aero_site, month, season, ndvi, sca
3242  print '(A,A,4(F11.6,1X))', trim(func_name), ", BRDF coeffs412: ", co412
3243  print '(A,A,4(F11.6,1X))', trim(func_name), ", BRDF coeffs470: ", co470
3244  print '(A,A,4(F11.6,1X))', trim(func_name), ", BRDF coeffs650: ", co650
3245  print '(A,A,3(F11.6,1x))', trim(func_name), ", BRDF SR, 412, s470, s650: ", s412, s470, s650
3246  end if
3247 
3248  status = 0
3249  return
3250 
3251  end function get_aeronet_brdf_sr
3252 
3253 ! -- Based on matching AERONET sites, return AOT value using appropriate AOT model.
3254 ! -- Returns 0 on success, otherwise -1.
3255  real function get_aot500(lat, lon, elev, sa, season, ndvi, gzone, lc_type, stdv02, &
3256  & aot412_91, aot412_93, aot412_94, aot412_96, aot412_995, &
3257  & aot470_91, aot470_92, aot470_93, aot470_94, aot470_95, aot470_96, aot470_995, &
3258  & aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust, &
3259  & aot470_91_dust, aot470_92_dust, aot470_93_dust, aot470_94_dust, aot470_95_dust, &
3260  & aot470_96_dust, aot470_995_dust, ae, status, debug) result(aot500)
3261 
3262  implicit none
3263 
3264  character(len=20), parameter :: func_name = "get_aot500"
3265 
3266  real, intent(in) :: lat
3267  real, intent(in) :: lon
3268  real, intent(in) :: elev ! -- surface elevation
3269  real, intent(in) :: sa ! -- scattering angle
3270  integer, intent(in) :: season
3271  real, intent(in) :: ndvi
3272  integer, intent(in) :: gzone
3273  integer, intent(in) :: lc_type
3274  real, intent(in) :: stdv02
3275  real, intent(in) :: aot412_91, aot412_93, aot412_94, aot412_96, aot412_995
3276  real, intent(in) :: aot470_91, aot470_92, aot470_93, aot470_94, aot470_95
3277  real, intent(in) :: aot470_96, aot470_995
3278  real, intent(in) :: aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust
3279  real, intent(in) :: aot470_91_dust, aot470_92_dust, aot470_93_dust, aot470_94_dust, aot470_95_dust
3280  real, intent(in) :: aot470_96_dust, aot470_995_dust
3281  real, intent(in) :: ae ! angstrom exponent
3282  integer, intent(inout) :: status
3283  logical, intent(in), optional :: debug
3284 
3285  real :: refsr650
3286  integer :: ilat, ilon
3287  integer :: m
3288 
3289  character(len=255) :: asite
3290  real, dimension(:), allocatable :: maero412, maero470, maero650
3291  integer, dimension(:), allocatable :: msiteindx
3292  integer, dimension(:), allocatable :: sorted
3293  real :: frac
3294  integer :: i, ii, jj, cnt
3295 
3296  real :: aot500_1, aot500_2
3297 
3298  logical :: dflag
3299 
3300  dflag = .false.
3301  if (present(debug)) dflag = debug
3302 
3303  status = 0
3304  aot500 = -999.0
3305 
3306  ! -- convert geolocation into array indices.
3307  ilat = floor(lat*10.0) + 900 + 1
3308  ilon = floor(lon*10.0) + 1800 + 1
3309 
3310  if (ilat > 1800) ilat = 1800
3311  if (ilon > 3600) ilon = 3600
3312  if (dflag) print *, trim(func_name)//', lat, lon, ilat, ilon: ', lat, lon, ilat, ilon
3313 
3314 ! -- set up our reference surface reflectance
3315  refsr650 = brdf650(ilon,ilat)
3316 
3317  ! -- do we have an AERONET site in the same zone with the same land cover type?
3318  m = 0
3319  m = count(aero_zones == gzone .AND. aero_types == lc_type .AND. (elev < 500 .EQV. aero_elev < 500))
3320 
3321 ! -- create exception for china, europe, spain, morocco -- match by zone and elevation only
3322  if (gzone == 16 .OR. (gzone == 17 .OR. gzone == 2) .OR. gzone == 22) then
3323  m = count(aero_zones == gzone .AND. (elev < 500 .EQV. aero_elev < 500))
3324  end if
3325 
3326 ! -- create exception for Fresno Valley, Australia - match by region only.
3327  if (gzone == 18 .OR. gzone == 12 .OR. (gzone == 26 .OR. gzone == 27) .OR. gzone == 29) then
3328  m = count(aero_zones == gzone)
3329  end if
3330 
3331 ! -- create exception for high elevation Tibet/China zone - match by region
3332 ! only.
3333  if (gzone == 28) then
3334  m = count(aero_zones == gzone)
3335  end if
3336 
3337 ! -- create exception for Jaipur zone - match by region only.
3338  if (gzone == 20) then
3339  m = count(aero_zones == gzone)
3340  end if
3341 
3342  ! -- create exception for NW_India_Desert zone - match by region only.
3343  if (gzone == 30) then
3344  m = count(aero_zones == gzone)
3345  end if
3346 
3347 ! -- create exception for Pune - match by region only.
3348  if (gzone == 19) then
3349  m = count(aero_zones == gzone)
3350  end if
3351 
3352 ! -- create exception for Kanpur - match by region only, 9 January 2018 JLee
3353  if (gzone == 15) then
3354  m = count(aero_zones == gzone)
3355  end if
3356 
3357 ! -- create exception for Sahel, geozone =5, landcover=2 to ignore elevation.
3358  if ((gzone == 5 .AND. lc_type == 2) .OR. gzone == 1 .or. gzone == 13) then
3359  m = count(aero_zones == gzone .AND. aero_types == lc_type)
3360  end if
3361 
3362 ! -- create exception for Barren North America, geozone =31 to ignore
3363 ! elevation above 750m.
3364  if (gzone == 31 .AND. elev < 750) then
3365  m = count(aero_zones == gzone)
3366  end if
3367 
3368  if (m > 0) then
3369 ! -- allocate our arrays to store the matching AERONET data.
3370 ! -- no explicit deallocate() as these should automatically be
3371 ! -- deallocated when the function ends.
3372  if (allocated(maero412)) deallocate(maero412, stat=status)
3373  if (allocated(maero470)) deallocate(maero470, stat=status)
3374  if (allocated(maero650)) deallocate(maero650, stat=status)
3375  if (allocated(msiteindx)) deallocate(msiteindx, stat=status)
3376  if (allocated(sorted)) deallocate(sorted, stat=status)
3377  allocate(maero412(m), maero470(m), maero650(m), msiteindx(m), &
3378  sorted(m), stat=status)
3379  if (status /= 0) then
3380  print *, "ERROR: Failed to allocate AERONET 650 SR match arrays: ", status
3381  return
3382  end if
3383 
3384  cnt = 0
3385 
3386 ! -- get and store base table SR values at each matching AERONET site at 412, 470, and 650.
3387  do i = 1, size(aero_sites) ! i = AERONET site index
3388  select case (gzone)
3389  case (2, 16, 17, 22) ! -- china, europe, spain, morocco, only match by zone, elevation
3390  if (aero_zones(i) == gzone .AND. (elev < 500 .EQV. aero_elev(i) < 500)) then
3391  cnt = cnt + 1
3392  maero412(cnt) = aero_sr412(i,season)
3393  maero470(cnt) = aero_sr470(i,season)
3394  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
3395  msiteindx(cnt) = i
3396 
3397  if (dflag) then
3398  print '(3(A,1X),I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
3399  print '(A,A,3(F11.6))', trim(func_name), ', AERONET Baseline SR, 412, 470, 650: ', &
3400  & maero412(cnt), maero470(cnt), maero650(cnt)
3401  end if
3402  end if
3403  case (18, 12, 20, 26, 27, 28, 29, 30, 31) ! Fresno Valley, Australia, only match by region
3404  if (aero_zones(i) == gzone) then
3405  cnt = cnt + 1
3406  maero412(cnt) = aero_sr412(i,season)
3407  maero470(cnt) = aero_sr470(i,season)
3408  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
3409  msiteindx(cnt) = i
3410 
3411  if (dflag) then
3412  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
3413  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
3414  end if
3415  end if
3416  case (15, 19) ! Pune, only match by region, added Kanpur and India high elevation 31 January 2018 JLee
3417  if (aero_zones(i) == gzone) then
3418  cnt = cnt + 1
3419  maero412(cnt) = aero_sr412(i,season)
3420  maero470(cnt) = aero_sr470(i,season)
3421  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
3422  msiteindx(cnt) = i
3423 
3424  if (dflag) then
3425  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
3426  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
3427  end if
3428  end if
3429  case (1, 5, 10, 13) ! N. Africa, Solar Villge (Saudi Arabia)
3430  if (aero_zones(i) == gzone .AND. aero_types(i) == lc_type) then
3431  cnt = cnt + 1
3432  maero412(cnt) = aero_sr412(i,season)
3433  maero470(cnt) = aero_sr470(i,season)
3434  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
3435  msiteindx(cnt) = i
3436 
3437  if (dflag) then
3438  print '(A,A,A,I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
3439  print '(A,A,3(F11.6,1X))', trim(func_name), ', AERONET Baseline SR: ', maero412(cnt), maero470(cnt), maero650(cnt)
3440  end if
3441  end if
3442  case default
3443  if (aero_zones(i) == gzone .AND. aero_types(i) == lc_type .AND. (elev < 500 .EQV. aero_elev(i) < 500)) then
3444  cnt = cnt + 1
3445  maero412(cnt) = aero_sr412(i,season)
3446  maero470(cnt) = aero_sr470(i,season)
3447  maero650(cnt) = aero_sr650(i,3) ! < -- always use summer for 650nm to match refsr650
3448  msiteindx(cnt) = i
3449 
3450  if (dflag) then
3451  print '(3(A,1X),I4,I4)', trim(func_name), ', matching site: ', trim(aero_sites(i)), aero_zones(i), aero_types(i)
3452  print '(A,A,3(F11.6))', trim(func_name), ', AERONET Baseline SR, 412, 470, 650: ', &
3453  & maero412(cnt), maero470(cnt), maero650(cnt)
3454  end if
3455  end if
3456  end select
3457  end do
3458 
3459 ! -- can we interpolate between zone's AERONET sites?
3460  call sortrx(m, maero650, sorted)
3461  if (refsr650 >= minval(maero650) .AND. refsr650 < maxval(maero650)) then
3462 
3463 ! -- find where refsr650 fits in maero650() and interpolate between the two sites
3464  do i = 1, m-1
3465  if (refsr650 >= maero650(sorted(i)) .AND. refsr650 < maero650(sorted(i+1))) then
3466  ii = sorted(i)
3467  asite = aero_sites(msiteindx(ii))
3468  aot500_1 = get_aeronet_aot500(asite, lat, lon, sa, season, ndvi, stdv02, &
3469  & aot412_91, aot412_93, aot412_94, aot412_96, aot412_995, &
3470  & aot470_91, aot470_92, aot470_93, aot470_94, aot470_95, aot470_96, aot470_995, &
3471  & aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust, &
3472  & aot470_91_dust, aot470_92_dust, aot470_93_dust, aot470_94_dust, aot470_95_dust, &
3473  & aot470_96_dust, aot470_995_dust, ae, status, debug=dflag)
3474  if (status /= 0) then
3475  print *, "ERROR: Failed to get AOT@500nm from AERONET site: ", trim(asite), status
3476  return
3477  end if
3478 
3479  jj = sorted(i+1)
3480  asite = aero_sites(msiteindx(jj))
3481  aot500_2 = get_aeronet_aot500(asite, lat, lon, sa, season, ndvi, stdv02, &
3482  & aot412_91, aot412_93, aot412_94, aot412_96, aot412_995, &
3483  & aot470_91, aot470_92, aot470_93, aot470_94, aot470_95, aot470_96, aot470_995, &
3484  & aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust, &
3485  & aot470_91_dust, aot470_92_dust, aot470_93_dust, aot470_94_dust, aot470_95_dust, &
3486  & aot470_96_dust, aot470_995_dust, ae, status, debug=dflag)
3487  if (status /= 0) then
3488  print *, "ERROR: Failed to get AOT@500nm from AERONET site: ", trim(asite), status
3489  return
3490  end if
3491 
3492 ! -- calculate AERONET site weights according to 650 values and adjust AOT.
3493  frac = (refsr650-maero650(ii)) / (maero650(jj)-maero650(ii))
3494 
3495  aot500 = (1.0-frac)*aot500_1 + frac*aot500_2
3496 
3497  if (dflag) then
3498  print *, trim(func_name), ", Pixel Ref. SR, 650: ", refsr650
3499 ! print *, trim(func_name), ", Pixel Baseline SR, 412, 470: ", xsfc412(ilon,ilat), xsfc470(ilon,ilat)
3500  print *, trim(func_name), ', interp sites: ', trim(aero_sites(msiteindx(ii))), ' ', trim(aero_sites(msiteindx(jj)))
3501  print *, trim(func_name), ', aot values, 412: ', aot412_91, aot412_93, aot412_94, aot412_96, aot412_995
3502  print *, trim(func_name), ", aot values, 470: ", aot470_91, aot470_92, aot470_93, &
3503  & aot470_94, aot470_95, aot470_96, aot470_995
3504  print *, trim(func_name), ', aot500: ', aot500
3505  end if
3506 
3507  exit ! jump out of loop, we're done!
3508 
3509  end if
3510  end do
3511 
3512 ! -- no interpolation, use single AERONET site.
3513  else
3514  if (refsr650 <= minval(maero650)) then
3515  ii = sorted(1) ! AERONET site w/ min. sr650 value
3516  else
3517  ii = sorted(m) ! AERONET site w/ max. sr650 value
3518  end if
3519 
3520  asite = aero_sites(msiteindx(ii))
3521  aot500 = get_aeronet_aot500( asite, lat, lon, sa, season, ndvi, stdv02, &
3522  & aot412_91, aot412_93, aot412_94, aot412_96, aot412_995, &
3523  & aot470_91, aot470_92, aot470_93, aot470_94, aot470_95, aot470_96, aot470_995, &
3524  & aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust, &
3525  & aot470_91_dust, aot470_92_dust, aot470_93_dust, aot470_94_dust, aot470_95_dust, &
3526  & aot470_96_dust, aot470_995_dust, ae, status, debug=dflag)
3527  if (status /= 0) then
3528  print *, "ERROR: Failed to get AOT at 500nm over AERONET site, single: ", trim(asite), status
3529  return
3530  end if
3531 
3532  if (dflag) then
3533  print *, trim(func_name), ", Pixel Ref. SR, 650: ", refsr650
3534 ! print *, trim(func_name), ", Pixel Baseline SR, 412, 470: ", xsfc412(ilon,ilat), xsfc470(ilon,ilat)
3535  print *, trim(func_name), ', interp site: ', trim(aero_sites(msiteindx(ii)))
3536  print *, trim(func_name), ', aot values, 412: ', aot412_91, aot412_93, aot412_94, aot412_96, aot412_995
3537  print *, trim(func_name), ", aot values, 470: ", aot470_91, aot470_92, aot470_93, &
3538  & aot470_94, aot470_95, aot470_96, aot470_995
3539  print *, trim(func_name), ', aot500: ', aot500
3540  end if
3541 
3542  end if
3543 ! -- no matching site, no rules to select model. Return error.
3544  else
3545  status = -1
3546  return
3547  end if
3548 
3549  return
3550 
3551  end function get_aot500
3552 
3553 ! -- returns AOT @ 500 nm over the AERONET site, aero_site for the given season.
3554 ! -- NOTE: thresholds below based on case studies over the each site and is specific to
3555 ! -- that site.
3556  real function get_aeronet_aot500(aero_site, lat, lon, sca, season, ndvi, stdv02, &
3557  & aot412_91, aot412_93, aot412_94, aot412_96, aot412_995, &
3558  & aot470_91, aot470_92, aot470_93, aot470_94, aot470_95, aot470_96, aot470_995, &
3559  & aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust, &
3560  & aot470_91_dust, aot470_92_dust, aot470_93_dust, aot470_94_dust, aot470_95_dust, &
3561  & aot470_96_dust, aot470_995_dust, ae, status, debug) result(aot500)
3562 
3563  implicit none
3564 
3565  character(len=20), parameter :: func_name = "get_aeronet_aot500"
3566 
3567  character(len=255), intent(in) :: aero_site
3568  real, intent(in) :: sca ! scattering angle
3569  real, intent(in) :: lat, lon
3570  integer, intent(in) :: season
3571  real, intent(in) :: ndvi
3572  real, intent(in) :: stdv02
3573  real, intent(in) :: aot412_91, aot412_93, aot412_94, aot412_96, aot412_995
3574  real, intent(in) :: aot470_91, aot470_92, aot470_93, aot470_94
3575  real, intent(in) :: aot470_95, aot470_96, aot470_995
3576  real, intent(in) :: aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust
3577  real, intent(in) :: aot470_91_dust, aot470_92_dust,aot470_93_dust, aot470_94_dust, aot470_95_dust
3578  real, intent(in) :: aot470_96_dust, aot470_995_dust
3579  real, intent(in) :: ae ! angstrom exponent
3580  integer, intent(inout) :: status
3581  logical, intent(in), optional :: debug
3582 
3583  real :: aot412_92
3584  real :: dd
3585  real :: model_frac, model_frac2
3586  logical :: dflag
3587 
3588  aot500 = -999.0
3589  model_frac = 0.0
3590  model_frac2 = 0.0
3591  status = 0
3592 
3593  dflag = .false.
3594  if (present(debug)) dflag = debug
3595 
3596  select case (aero_site)
3597 
3598  case ("Agoufou") !----------------------------------------------
3599  select case (season)
3600 
3601 ! -- winter
3602  case (1)
3603  aot500 = aot412_94
3604  if (aot412_94 >= 0.6) then
3605  aot500 = (aot412_93 + aot412_91)/2.0
3606  end if
3607 
3608 ! -- spring
3609  case (2)
3610  aot500 = aot470_96
3611  if (aot412_94 >= 0.6) then
3612  aot500 =aot470_92
3613  end if
3614  if (aot500 >= 1.3) then
3615  aot500 = (aot470_91 + aot470_92)/2.0
3616  end if
3617 
3618 ! -- summer
3619  case (3)
3620  aot500 = aot470_96
3621  if (aot470_96 >= 0.5) then
3622  aot500 = aot470_93
3623  end if
3624  if (aot470_96 >= 0.7) then
3625  aot500 = aot470_91 * 1.1
3626  end if
3627 
3628 ! -- fall
3629  case (4)
3630  aot500 = aot412_94
3631  if (aot412_94 >= 0.5) then
3632  aot500 = (aot412_91 + aot412_93) / 2.0
3633  end if
3634 
3635 ! -- default
3636  case default
3637  print *, "ERROR: Invalid season specified: ", season
3638  status = -1
3639  return
3640 
3641  end select
3642 
3643  case ("IER_Cinzana") !------------------------------------------
3644  select case (season)
3645 
3646 ! -- winter
3647  case (1)
3648  aot500 = aot470_94
3649  if (aot470_94 >= 0.8) then
3650  aot500 = aot470_93
3651  end if
3652  !if (aot470_94 >= 0.7) then
3653  ! aot500 = aot470_91
3654  !end if
3655 
3656 ! -- spring
3657  case (2)
3658  aot500 = aot470_96
3659  if (aot500 > 0.6) then
3660  aot500 = aot470_95
3661  end if
3662  !if (aot470_94 > 1.0) then
3663  ! aot500 = aot470_93
3664  !endif
3665 
3666 ! -- summer
3667  case (3)
3668  aot500 = aot470_96
3669  if (ndvi >= 0.3) then
3670  aot500 = aot412_94
3671  else
3672  aot500 = aot470_995
3673  end if
3674 
3675 ! -- fall
3676  case (4)
3677  if (ndvi < 0.36) then
3678  aot500 = aot412_94
3679  else
3680  aot500 = aot470_96
3681  endif
3682 
3683  case default
3684  print *, "ERROR: Invalid season specified: ", season
3685  status = -1
3686  return
3687 
3688  end select
3689 
3690  case ("Zinder_Airport") !--------------------------------------
3691  select case (season)
3692 
3693 ! -- winter
3694  case (1)
3695  aot500 = aot470_96
3696 
3697 ! -- spring
3698  case (2)
3699  aot500 = aot412_94
3700 
3701 ! -- summer
3702  case (3)
3703  aot500 = aot470_96
3704  if (aot470_96 > 0.6 .AND. ndvi < 0.18) then
3705  aot500 = aot470_93
3706  end if
3707  if (aot470_96 > 1.0 .AND. ndvi < 0.18) then
3708  aot500 = aot470_92
3709  end if
3710 
3711 ! -- fall
3712  case (4)
3713  aot500 = aot412_94
3714 
3715  case default
3716  print *, "ERROR: Invalid season specified: ", season
3717  status = -1
3718  return
3719 
3720  end select
3721 
3722  case ("Banizoumbou") !------------------------------------------
3723  select case (season)
3724 
3725 ! -- winter
3726  case (1)
3727  aot500 = aot412_94
3728  if (aot500 < 0.4) then
3729  aot500 = (aot412_96 + aot412_995) / 2.0
3730  else
3731  aot500 = aot412_93
3732  end if
3733 
3734 ! if (aot470_94 > 0.6) then
3735 ! aot500 = (aot470_96 + aot470_94)/2.0
3736 ! end if
3737 
3738 ! -- spring
3739  case (2)
3740  aot500 = aot412_93
3741  !if (ndvi >= 0.12) then
3742  ! aot500 = aot470_94
3743  !end if
3744 ! -- summer
3745  case (3)
3746  aot500 = (aot470_96 + aot470_995) / 2.0
3747  if (aot470_96 > 0.7) then
3748  aot500 = aot470_96
3749  end if
3750 
3751 ! -- fall
3752  case (4)
3753  aot500 = aot470_96
3754 ! if (ndvi > 0.24) then
3755 ! aot500 = aot412_94
3756 ! else
3757 ! aot500 = aot470_96
3758 ! end if
3759 
3760 ! if (aot470_94 > 0.4) then
3761 ! aot500 = aot412_93
3762 ! end if
3763  case default
3764  print *, "ERROR: Invalid season specified: ", season
3765  status = -1
3766  return
3767 
3768  end select
3769 
3770 
3771  case ("Kanpur") !------------------------------------------
3772  select case (season)
3773 ! -- winter
3774  case (1)
3775  aot500 = aot412_96
3776  if (lon > 85) then !Dhaka University needs more absorbing aerosol model, longitudinal dependence for smooth transition
3777  if (lon < 90) then
3778  model_frac2 = 1.0-(lon-85.0)/5.0
3779  else
3780  model_frac2 = 0.0
3781  end if
3782 
3783  if (aot500 < 0.5) then
3784  model_frac = 1.0
3785  elseif (aot500 < 1.0) then
3786  model_frac = 1.0-(aot500-0.5)/0.5*(1.0-model_frac2)
3787  else
3788  model_frac = model_frac2
3789  end if
3790  aot500 = aot412_96*model_frac+aot412_94*(1.0-model_frac)
3791  endif
3792 
3793 ! -- spring
3794  case (2)
3795  aot500 = aot412_96
3796  if (aot500 < 0.6) then
3797  model_frac = 1.0
3798  elseif (aot500 < 1.2) then
3799  model_frac = 1.0-(aot500-0.6)/0.6
3800  else
3801  model_frac = 0.0
3802  end if
3803  aot500 = aot412_96*model_frac+aot412_94*(1.0-model_frac)
3804 
3805 ! -- summer
3806  case (3)
3807  aot500 = aot412_96
3808 
3809 ! -- fall
3810  case (4)
3811  aot500 = aot412_96
3812  if (lon > 85) then
3813  if (lon < 90) then
3814  model_frac2 = 1.0-(lon-85.0)/5.0
3815  else
3816  model_frac2 = 0.0
3817  end if
3818 
3819  if (aot500 < 0.5) then
3820  model_frac = 1.0
3821  elseif (aot500 < 1.0) then
3822  model_frac = 1.0-(aot500-0.5)/0.5*(1.0-model_frac2)
3823  else
3824  model_frac = model_frac2
3825  end if
3826  aot500 = aot412_96*model_frac+aot412_94*(1.0-model_frac)
3827  endif
3828 
3829  case default
3830  print *, "ERROR: Invalid season specified: ", season
3831  status = -1
3832  return
3833 
3834  end select
3835 
3836  case ("Tinga_Tingana") !----------------------------------------
3837  select case (season)
3838 
3839 ! -- all seasons
3840  case (1,2,3,4)
3841  if (aot412_94 < 1.2) then
3842  aot500 = aot412_995
3843  else
3844  aot500 = aot412_94
3845  end if
3846 ! aot500 = aot412_995
3847 ! aot500 = aot412_94
3848 ! if (aot412_995 > 0.2 .AND. stdv02 < 0.002 .AND. ndvi < 0.1) then
3849 ! if (aot412_995 >= 0.3) then
3850 ! aot500 = aot412_94
3851 ! end if
3852 ! if (aot412_995 >= 0.2 .AND. aot412_995 < 0.3) then
3853 ! dd = (aot412_995 - 0.2) / 0.1
3854 ! aot500 = aot412_995 * (1.0-dd) + aot412_94*dd
3855 ! end if
3856 ! end if
3857 
3858  case default
3859  print *, "ERROR: Invalid season specified: ", season
3860  status = -1
3861  return
3862 
3863  end select
3864 
3865  case ("GZ24_Only") !----------------------------------------
3866  select case (season)
3867 ! -- winter, summer, fall
3868  case (1,3,4)
3869  if (aot412_94 < 1.2) then
3870  aot500 = aot412_995
3871  else
3872  aot500 = aot412_94
3873  end if
3874 
3875 ! -- spring
3876  case (2)
3877  if (aot412_94 < 0.5) then
3878  aot500 = aot412_995
3879  else
3880  aot500 = aot412_94
3881  endif
3882 
3883  case default
3884  print *, "ERROR: Invalid season specified: ", season
3885  status = -1
3886  return
3887  end select
3888 
3889  case ("Fresno_2") !------------------------------------------------
3890  select case (season)
3891 
3892 ! -- winter
3893  case (1)
3894  aot500 = aot470_96
3895  if (aot500 < 0.5) then
3896  model_frac = 1.0-(aot500-0.0)/0.5
3897  aot500 = aot470_96*model_frac + aot470_94*(1.0-model_frac)
3898  else
3899  aot500 = aot470_94
3900  endif
3901 
3902 ! -- spring
3903  case (2)
3904  aot500 = aot470_995
3905  if (aot500 < 0.5) then
3906  model_frac = 1.0-(aot500-0.0)/0.5
3907  aot500 = aot470_995*model_frac + aot470_94*(1.0-model_frac)
3908  else
3909  aot500 = aot470_94
3910  endif
3911 
3912 ! -- summer
3913  case (3)
3914  aot500 = aot470_96
3915 
3916 ! -- fall
3917  case (4)
3918  aot500 = aot470_995
3919  if (aot500 < 0.5) then
3920  model_frac = 1.0-(aot500-0.0)/0.5
3921  aot500 = aot470_995*model_frac + aot470_94*(1.0-model_frac)
3922  else
3923  aot500 = aot470_94
3924  endif
3925 
3926  case default
3927  print *, "ERROR: Invalid season specified: ", season
3928  status = -1
3929  return
3930 
3931  end select
3932 
3933  case ("Fresno_GZ18") !------------------------------------------------
3934  select case (season)
3935 
3936 ! -- winter
3937  case (1)
3938  aot500 = aot470_96
3939 
3940 ! -- spring
3941  case (2)
3942  aot500 = aot470_96
3943 
3944 ! -- summer
3945  case (3)
3946  aot500 = aot470_995
3947  if (aot470_995 > 0.3) then
3948  aot500 = aot470_96 + aot470_995 / 2.0
3949  end if
3950 
3951 ! -- fall
3952  case (4)
3953  aot500 = aot470_96
3954 
3955  case default
3956  print *, "ERROR: Invalid season specified: ", season
3957  status = -1
3958  return
3959 
3960  end select
3961 
3962  case ("CCNY") !------------------------------------------------
3963  select case (season)
3964 
3965 ! -- winter
3966  case (1)
3967  aot500 = aot470_995
3968 
3969 ! -- spring
3970  case (2)
3971  aot500 = aot412_995
3972 
3973 ! -- summer
3974  case (3)
3975  aot500 = aot470_995
3976 
3977 ! -- fall
3978  case (4)
3979  aot500 = aot470_96
3980 
3981  case default
3982  print *, "ERROR: Invalid season specified: ", season
3983  status = -1
3984  return
3985 
3986  end select
3987 
3988  case ("Beijing") !----------------------------------------------
3989  select case (season)
3990 
3991 ! -- winter
3992  case (1)
3993  aot500 = aot470_96
3994  if (aot470_96 > 0.5) then
3995  aot500 = (aot470_94+aot470_92)/2.
3996  end if
3997 
3998 ! -- spring
3999  case (2)
4000  aot500 = aot470_96
4001  if (ndvi < 0.18 .and. aot470_96 > 0.4) then
4002  aot500 = (aot470_94+aot470_96)/2.
4003  end if
4004 
4005  if (aot470_96 > 0.6) then
4006  aot500 = aot470_94
4007  end if
4008 
4009 ! -- summer
4010  case (3)
4011  aot500 = aot470_96
4012 
4013  if (aot470_96 > 1.0) then
4014  aot500 = (aot470_94+aot470_96)/2.
4015  end if
4016 
4017 ! -- fall
4018  case (4)
4019  aot500 = aot470_96
4020 
4021  if (aot470_96 > 0.7) then
4022  aot500 = aot470_94
4023  end if
4024 
4025  case default
4026  print *, "ERROR: Invalid season specified: ", season
4027  status = -1
4028  return
4029 
4030  end select
4031 
4032  case ("Hamim") !----------------------------------------
4033  select case (season)
4034 
4035 ! -- all seasons
4036  case (1,2,3,4)
4037  aot500 = aot412_94
4038 
4039  case default
4040  print *, "ERROR: Invalid season specified: ", season
4041  status = -1
4042  return
4043 
4044  end select
4045 
4046  case ("Moldova") !----------------------------------------
4047  select case (season)
4048 ! -- all seasons
4049  case (1)
4050  aot500 = aot470_96
4051  case (2)
4052  aot500 = aot412_995
4053  case (3)
4054  aot500 = aot470_96
4055  case (4)
4056  aot500 = aot412_995
4057  case default
4058  print *, "ERROR: Invalid season specified: ", season
4059  status = -1
4060  return
4061 
4062  end select
4063 
4064  case ("Modena") !----------------------------------------
4065  select case (season)
4066  case (1)
4067  aot500 = aot470_96
4068  case (2)
4069  aot500 = aot470_96
4070  if (aot470_96 < 0.4) then
4071  aot500 = aot470_995
4072  end if
4073  case (3)
4074  aot500 = aot470_96
4075  if (aot470_96 < 0.4) then
4076  aot500 = aot470_995
4077  end if
4078  case (4)
4079  aot500 = aot470_96
4080  if (aot470_96 < 0.3) then
4081  aot500 = aot470_995
4082  end if
4083  case default
4084  print *, "ERROR: Invalid season specified: ", season
4085  status = -1
4086  return
4087  end select
4088 
4089  case ("Ispra") !----------------------------------------
4090  select case (season)
4091  case (1,2,3,4)
4092  aot500 = aot470_96
4093 
4094  case default
4095  print *, "ERROR: Invalid season specified: ", season
4096  status = -1
4097  return
4098  end select
4099 
4100  case ("Palencia") !----------------------------------------
4101  select case (season)
4102  case (1)
4103  if (ndvi < 0.28) then
4104  aot500 = aot412_995
4105  else
4106  aot500 = aot470_995
4107  endif
4108 
4109  case(2)
4110  aot500 = aot470_995
4111 
4112  case(3)
4113  aot500 = aot412_995
4114  if (aot412_995 > 0.2) then
4115  aot500 = aot412_96
4116  end if
4117  if (aot412_995 > 0.3) then
4118  aot500 = aot412_94
4119  end if
4120 
4121  case (4)
4122  aot500 = aot470_995
4123 
4124  case default
4125  print *, "ERROR: Invalid season specified: ", season
4126  status = -1
4127  return
4128 
4129  end select
4130 
4131  case ("Saada") !----------------------------------------
4132  select case (season)
4133  case (1,4)
4134  aot500 = aot470_96
4135  if (aot412_94 >= 0.4) then
4136  aot500 = aot470_94
4137  end if
4138  if (aot412_94 >= 0.8) then
4139  aot500 = aot470_92
4140  end if
4141  case (2,3)
4142  aot500 = aot470_96
4143  if (aot412_94 >= 0.4) then
4144  aot500 = aot470_94
4145  end if
4146  if (aot412_94 >= 0.8) then
4147  aot500 = aot470_92
4148  end if
4149  if (stdv02 > 0.007) then
4150  aot500 = aot470_995
4151  end if
4152  case default
4153  print *, "ERROR: Invalid season specified: ", season
4154  status = -1
4155  return
4156  end select
4157 
4158  case ("Solar_Village") !----------------------------------------
4159  select case (season)
4160  case (1)
4161  aot500 = aot412_93
4162  if (aot412_93 > 0.5) then
4163  aot500 = (aot412_93 + aot412_91) / 2.0
4164  end if
4165 
4166  case (2)
4167  aot500 = aot412_93
4168  ! if (aot412_94 > 0.4) then
4169 ! aot500 = aot412_93
4170 ! end if
4171 ! if (aot412_94 > 0.8) then
4172 ! aot500 = (aot412_91 + aot412_93) / 2.0
4173 ! end if
4174  case (3)
4175  aot500 = aot412_94
4176 
4177  case (4)
4178  aot500 = aot412_96
4179 
4180  case default
4181  print *, "ERROR: Invalid season specified: ", season
4182  status = -1
4183  return
4184  end select
4185 
4186  case ("Lecce_University") !----------------------------------------
4187  select case (season)
4188  case (1)
4189  aot500 = aot470_96
4190  case (2)
4191  if (ndvi > 0.4) then
4192  aot500 = aot412_94
4193  else
4194  aot500 = (aot470_96 + aot470_995) / 2.0
4195  end if
4196 
4197  case (3)
4198  aot500 = aot412_995
4199  if (aot412_995 < 0.2) then
4200  aot500 = aot412_96
4201  end if
4202 
4203  case (4)
4204  aot500 = aot470_96
4205 
4206  case default
4207  print *, "ERROR: Invalid season specified: ", season
4208  status = -1
4209  return
4210  end select
4211 
4212  case ("Carpentras") !----------------------------------------
4213  select case (season)
4214  case (1)
4215  !aot500 = aot470_96
4216  aot500 = aot412_93
4217  case (3,4)
4218  !aot500 = aot470_96
4219  aot500 = aot412_995
4220  case (2)
4221  if(ndvi < 0.3) then
4222  !aot500 = aot412_94
4223  aot500 = aot412_96
4224  else
4225  aot500 = aot470_96
4226  end if
4227  case default
4228  print *, "ERROR: Invalid season specified: ", season
4229  status = -1
4230  return
4231  end select
4232 
4233  case ("Trelew") !----------------------------------------
4234  select case (season)
4235 
4236 ! -- all seasons
4237  case(1)
4238  aot500 = aot470_96
4239  case (2,3)
4240  aot500 = aot470_96
4241  case (4)
4242  if (ndvi < 0.2) then
4243  aot500 = aot412_94
4244  else
4245  aot500 = aot470_96
4246  end if
4247 
4248  case default
4249  print *, "ERROR: Invalid season specified: ", season
4250  status = -1
4251  return
4252 
4253  end select
4254 
4255  case ("Pune") !----------------------------------------
4256  select case (season)
4257 
4258 ! -- winter
4259  case (1)
4260  aot500 = aot412_96
4261  if (aot500 < 0.5) then
4262  model_frac = 1.0
4263  elseif (aot500 < 1.0) then
4264  model_frac = 1.0-(aot500-0.5)/0.5
4265  else
4266  model_frac = 0.0
4267  end if
4268  aot500 = aot412_96*model_frac+aot412_94*(1.0-model_frac)
4269 
4270 ! -- spring
4271  case (2)
4272  aot500 = aot412_96
4273  if (aot500 < 0.6) then
4274  model_frac = 1.0
4275  elseif (aot500 < 1.2) then
4276  model_frac = 1.0-(aot500-0.6)/0.6
4277  else
4278  model_frac = 0.0
4279  end if
4280  aot500 = aot412_96*model_frac+aot412_94*(1.0-model_frac)
4281 
4282 ! -- summer
4283  case (3)
4284  aot500 = aot412_96
4285 
4286 ! -- fall
4287  case (4)
4288  aot500 = aot412_96
4289  if (lon > 85) then
4290  if (lon < 90) then
4291  model_frac2 = 1.0-(lon-85.0)/5.0
4292  else
4293  model_frac2 = 0.0
4294  end if
4295 
4296  if (aot500 < 0.5) then
4297  model_frac = 1.0
4298  elseif (aot500 < 1.0) then
4299  model_frac = 1.0-(aot500-0.5)/0.5*(1.0-model_frac2)
4300  else
4301  model_frac = model_frac2
4302  end if
4303  aot500 = aot412_96*model_frac+aot412_94*(1.0-model_frac)
4304  endif
4305 
4306  case default
4307  print *, "ERROR: Invalid season specified: ", season
4308  status = -1
4309  return
4310 
4311  end select
4312 
4313  case ("Evora") !----------------------------------------
4314  select case (season)
4315 ! -- winter
4316  case (1)
4317  aot500 = aot470_96
4318 
4319 ! -- spring
4320  case (2)
4321  aot500 = aot412_94
4322 
4323 ! -- summer
4324  case (3)
4325  aot500 = aot470_995
4326 
4327 ! -- fall
4328  case (4)
4329  aot500 = aot412_995
4330 
4331  case default
4332  print *, "ERROR: Invalid season specified: ", season
4333  status = -1
4334  return
4335 
4336  end select
4337  case ("Blida") !----------------------------------------
4338  select case (season)
4339 ! -- winter
4340  case (1)
4341  aot500 = aot470_96
4342 
4343 ! -- spring
4344  case (2)
4345  aot500 = aot470_96
4346 
4347 ! -- summer
4348  case (3)
4349  aot500 = aot470_96
4350 
4351 ! -- fall
4352  case (4)
4353  aot500 = aot470_96
4354 
4355  case default
4356  print *, "ERROR: Invalid season specified: ", season
4357  status = -1
4358  return
4359 
4360  end select
4361  case ("Blida_High") !----------------------------------------
4362  select case (season)
4363 ! -- winter
4364  case (1)
4365  aot500 = aot470_96
4366 
4367 ! -- spring
4368  case (2)
4369  aot500 = aot470_96
4370 
4371 ! -- summer
4372  case (3)
4373  aot500 = aot470_96
4374 
4375 ! -- fall
4376  case (4)
4377  aot500 = aot470_96
4378 
4379  case default
4380  print *, "ERROR: Invalid season specified: ", season
4381  status = -1
4382  return
4383 
4384  end select
4385  case ("Ilorin") !------------------------------------------
4386  select case (season)
4387 
4388 ! -- winter
4389  case (1)
4390  aot412_92 = (aot412_91+aot412_93)/2.0
4391  aot500 = aot412_92
4392 
4393 ! aot500 = aot412_94
4394 ! if (aot500 < 0.5) then
4395 ! model_frac = 1.0
4396 ! elseif (aot500 < 1.2) then
4397 ! model_frac = 1.0-(aot500-0.5)/0.7
4398 ! else
4399 ! model_frac = 0.0
4400 ! end if
4401 ! aot500 = aot412_94*model_frac+aot412_91*(1.0-model_frac)
4402 
4403 ! if (aot412_94 > 0.6) then
4404 ! aot500 = aot412_91
4405 ! else if (aot412_94 > 0.4) then
4406 ! aot500 = aot412_94
4407 ! else
4408 ! aot500 = aot412_96
4409 ! endif
4410 
4411 ! -- spring
4412  case (2)
4413  aot500 = aot412_94
4414  if (aot500 < 0.5) then
4415  model_frac = 1.0
4416  elseif (aot500 < 1.0) then
4417  model_frac = 1.0-(aot500-0.5)/0.5
4418  else
4419  model_frac = 0.0
4420  end if
4421  aot500 = aot412_94*model_frac+aot412_93*(1.0-model_frac)
4422 
4423 ! aot500 = aot412_94
4424 ! if (aot412_94 > 1.0) then
4425 ! aot500 = aot412_93
4426 ! end if
4427 ! if (aot412_94 > 1.5) then
4428 ! aot500 = aot412_91
4429 ! end if
4430 
4431 ! -- summer
4432  case (3)
4433  aot500 = aot412_96
4434 
4435 ! -- fall
4436  case (4)
4437  aot500 = aot412_94
4438 ! aot500 = aot412_94
4439 ! if (aot412_94 > 0.5) then
4440 ! aot500 = aot412_93
4441 ! end if
4442 ! if (aot412_94 > 0.8) then
4443 ! aot500 = aot412_91
4444 ! end if
4445  case default
4446  print *, "ERROR: Invalid season specified: ", season
4447  status = -1
4448  return
4449 
4450  end select
4451  case ("Ilorin_Transition") !------------------------------------------
4452  select case (season)
4453 
4454 ! -- winter
4455  case (1)
4456  aot500 = aot412_96
4457  if (aot500 < 0.5) then
4458  model_frac = 1.0
4459  elseif (aot500 < 1.0) then
4460  model_frac = 1.0-(aot500-0.5)/0.5
4461  else
4462  model_frac = 0.0
4463  end if
4464  aot500 = aot412_96*model_frac+aot412_94*(1.0-model_frac)
4465 
4466 ! if (aot412_94 > 0.5) then
4467 ! aot500 = aot412_94
4468 ! else
4469 ! aot500 = aot412_96
4470 ! end if
4471 
4472 ! -- spring
4473  case (2)
4474  aot500 = aot412_995
4475  if (aot412_94 < 0.5) then
4476  model_frac = 1.0
4477  elseif (aot412_94 < 1.0) then
4478  model_frac = 1.0-(aot500-0.5)/0.5
4479  else
4480  model_frac = 0.0
4481  end if
4482  aot500 = aot412_995*model_frac+aot412_96*(1.0-model_frac)
4483 
4484 ! aot500 = aot412_995
4485 ! if (aot412_94 > 1.0) then
4486 ! aot500 = aot412_96
4487 ! end if
4488 ! if (aot412_94 > 1.5) then
4489 ! aot500 = aot412_96
4490 ! end if
4491 
4492 ! -- summer
4493  case (3)
4494  aot500 = aot412_995
4495 
4496 ! -- fall
4497  case (4)
4498  aot500 = aot412_995
4499  if (aot412_94 < 0.5) then
4500  model_frac = 1.0
4501  elseif (aot412_94 < 1.0) then
4502  model_frac = 1.0-(aot500-0.5)/0.5
4503  else
4504  model_frac = 0.0
4505  end if
4506  aot500 = aot412_995*model_frac+aot412_96*(1.0-model_frac)
4507 
4508 ! aot500 = aot412_995
4509 ! if (aot412_94 > 0.5) then
4510 ! aot500 = aot412_96
4511 ! end if
4512 ! if (aot412_94 > 0.8) then
4513 ! aot500 = aot412_94
4514 ! end if
4515  case default
4516  print *, "ERROR: Invalid season specified: ", season
4517  status = -1
4518  return
4519 
4520  end select
4521 
4522  case ("SACOL") !----------------------------------------
4523  select case (season)
4524  case (1,2,3,4)
4525  aot500 = aot470_995
4526 
4527  case default
4528  print *, "ERROR: Invalid season specified: ", season
4529  status = -1
4530  return
4531 
4532  end select
4533 
4534  case ("Mexico_City") !----------------------------------------
4535  select case (season)
4536  case (1)
4537  aot500 = aot412_96
4538 
4539  case (2)
4540  aot500 = aot412_995
4541 
4542  case (3)
4543  aot500 = aot470_96
4544 
4545  case (4)
4546  aot500 = aot412_96
4547 
4548  case default
4549  print *, "ERROR: Invalid season specified: ", season
4550  status = -1
4551  return
4552 
4553  end select
4554 
4555  case ("Jaipur") !----------------------------------------
4556  select case (season)
4557  case (1)
4558  aot500 = aot412_96
4559 
4560  case (2)
4561  aot500 = aot412_96
4562 
4563  case(3)
4564  aot500 = aot412_96
4565 
4566  case (4)
4567  aot500 = aot412_96
4568 
4569  case default
4570  print *, "ERROR: Invalid season specified: ", season
4571  status = -1
4572  return
4573 
4574  end select
4575 
4576  case ("NW_India_Desert") !----------------------------------------
4577  select case (season)
4578  case (1)
4579  aot500 = aot412_94
4580 
4581  case (2)
4582  aot500 = aot412_94
4583 
4584  case(3)
4585  aot500 = aot412_94
4586 
4587  case (4)
4588  aot500 = aot412_96
4589 
4590  case default
4591  print *, "ERROR: Invalid season specified: ", season
4592  status = -1
4593  return
4594 
4595  end select
4596 
4597  case ("Yuma") !----------------------------------------
4598  select case (season)
4599  case (1)
4600  aot500 = aot412_995
4601 
4602  case (2)
4603  aot500 = aot470_995
4604 
4605  case (3)
4606  aot500 = aot412_995
4607 
4608  case (4)
4609  aot500 = aot412_995
4610 
4611  case default
4612  print *, "ERROR: Invalid season specified: ", season
4613  status = -1
4614  return
4615  end select
4616 
4617  case default !--------------------------------------------------
4618  print *, "ERROR: No data for AERONET site specified: ", aero_site
4619  status = -1
4620  aot500 = -999.0
4621  return
4622 
4623  end select ! -- AERONET site
4624 
4625  if (dflag) then
4626  print *, trim(func_name), ', AERONET site: ', aero_site
4627  print *, trim(func_name), ', season, ndvi, stdv02: ', season, ndvi, stdv02
4628  print '(A,A,12(F10.4,1x))', trim(func_name), ', aot values: ', aot412_91, aot412_93, aot412_94, &
4629  & aot412_96, aot412_995, aot470_91, aot470_92, aot470_93, &
4630  & aot470_94, aot470_95, aot470_96, aot470_995
4631  print *, trim(func_name), ', ae: ', ae
4632  print *, trim(func_name), ', aot500: ', aot500
4633  end if
4634  return
4635 
4636  end function get_aeronet_aot500
4637 
4638 ! -- Find granule limits and set LER offsets, and allocate space for the tables
4639  integer function set_limits(locedge, lat, long) RESULT(status)
4640 
4641  integer, intent(in) :: locedge(2)
4642  real, intent(in) :: lat(locedge(1),locedge(2)), long(locedge(1),locedge(2))
4643 
4644  integer :: checkvariable
4645  integer :: i, j
4646  character (len=256) :: msg
4647  real :: eastedge, westedge
4648  status = 0
4649 
4650 ! -- if processing extracts, if region of interest is within bounds of the granule,
4651 ! -- but not actually contained in the granule quadralateral, lat and lon values may be
4652 ! -- set to fill values (-999). Check this condition and fail.
4653 ! -- @TODO - utilize the status variable and check where called.
4654 ! if (minval(lat) < -900.0 .OR. minval(long) < -900.0) then
4655 ! msg = "Min lat or min lon is fill value. Failing."
4656 ! call MODIS_SMF_SETDYNAMICMSG(MODIS_F_GENERIC, msg, 'set_limits')
4657 ! end if
4658 
4659  eastedge = -999.0
4660  westedge = 999.0
4661  dateline = 0
4662  if (minval(long, long > -900.0) < -175.0 .and. maxval(long, long > -900.0) > 175.0) then
4663  eastedge = 180.0
4664  westedge = -180.0
4665  do i=1, locedge(1)
4666  do j=1, locedge(2)
4667  if (long(i,j) < -900.0) cycle ! skip undefined
4668  if (long(i,j) > 0.0 .and. long(i,j) < eastedge) eastedge = long(i,j)
4669  if (long(i,j) < 0.0 .and. long(i,j) > westedge) westedge = long(i,j)
4670  enddo
4671  enddo
4672  lerstart(1) = 10*(180+floor(eastedge)-1)
4673  if (lerstart(1) .le. 0) lerstart(1) = 1
4674  dateline = 3600 - lerstart(1)
4675  leredge(1) = 10*(180+(floor(westedge)+2)) + dateline
4676  else
4677  lerstart(1) = 10*(180+(floor(minval(long, long > -900.0))-1))
4678  if (lerstart(1) .le. 0) lerstart(1) = 1
4679  leredge(1) = 10*(180+(floor(maxval(long, long > -900.0))+2)) - lerstart(1)
4680  if (leredge(1)+lerstart(1) > 3600) leredge(1) = 3600 - lerstart(1)
4681  endif
4682 
4683  lerstart(2) = 10*(90+(floor(minval(lat, lat > -900.0))-1))
4684  if (lerstart(2) .le. 0) lerstart(2) = 1
4685  leredge(2) = 10*(90+(floor(maxval(lat, lat > -900.0))+2)) - lerstart(2)
4686  if (leredge(2)+lerstart(2) > 1800) leredge(2) = 1800 - lerstart(2)
4687 
4688  if (allocated(gref412_all)) deallocate(gref412_all)
4689  allocate (gref412_all(leredge(1),leredge(2)), stat = checkvariable)
4690  if ( checkvariable /= 0 ) goto 90
4691 
4692  if (allocated(gref470_all)) deallocate(gref470_all)
4693  allocate (gref470_all(leredge(1),leredge(2)), stat = checkvariable)
4694  if ( checkvariable /= 0 ) goto 90
4695 
4696  if (allocated(gref650_all)) deallocate(gref650_all)
4697  allocate (gref650_all(leredge(1),leredge(2)), stat = checkvariable)
4698  if ( checkvariable /= 0 ) goto 90
4699 
4700  if (allocated(gref412_fwd)) deallocate(gref412_fwd)
4701  allocate (gref412_fwd(leredge(1),leredge(2)), stat = checkvariable)
4702  if ( checkvariable /= 0 ) goto 90
4703 
4704  if (allocated(gref470_fwd)) deallocate(gref470_fwd)
4705  allocate (gref470_fwd(leredge(1),leredge(2)), stat = checkvariable)
4706  if ( checkvariable /= 0 ) goto 90
4707 
4708  if (allocated(gref650_fwd)) deallocate(gref650_fwd)
4709  allocate (gref650_fwd(leredge(1),leredge(2)), stat = checkvariable)
4710  if ( checkvariable /= 0 ) goto 90
4711 
4712  !if (allocated(gref412_bkd)) deallocate(gref412_bkd)
4713  !allocate (gref412_bkd(LERedge(1),LERedge(2)), stat = checkvariable)
4714  !if ( checkvariable /= 0 ) goto 90
4715 
4716  !if (allocated(gref470_bkd)) deallocate(gref470_bkd)
4717  !allocate (gref470_bkd(LERedge(1),LERedge(2)), stat = checkvariable)
4718  !if ( checkvariable /= 0 ) goto 90
4719 
4720  !if (allocated(gref650_bkd)) deallocate(gref650_bkd)
4721  !allocate (gref650_bkd(LERedge(1),LERedge(2)), stat = checkvariable)
4722  !if ( checkvariable /= 0 ) goto 90
4723 
4724  if (allocated(gref865_all)) deallocate(gref865_all)
4725  allocate (gref865_all(leredge(1),leredge(2)), stat = checkvariable)
4726  if ( checkvariable /= 0 ) goto 90
4727 
4728  !if (allocated(coefs412_all_tp)) deallocate(coefs412_all_tp)
4729  !allocate (coefs412_all_tp(LERedge(1),LERedge(2),4,3,2), stat = checkvariable)
4730  !if ( checkvariable /= 0 ) goto 90
4731 
4732  !if (allocated(coefs412_fwd_tp)) deallocate(coefs412_fwd_tp)
4733  !allocate (coefs412_fwd_tp(LERedge(1),LERedge(2),4,3,2), stat = checkvariable)
4734  !if ( checkvariable /= 0 ) goto 90
4735 
4736  if (allocated(coefs412_all)) deallocate(coefs412_all)
4737  allocate (coefs412_all(leredge(1),leredge(2),4,3), stat = checkvariable)
4738  if ( checkvariable /= 0 ) goto 90
4739 
4740  if (allocated(coefs412_fwd)) deallocate(coefs412_fwd)
4741  allocate (coefs412_fwd(leredge(1),leredge(2),4,3), stat = checkvariable)
4742  if ( checkvariable /= 0 ) goto 90
4743 
4744  !if (allocated(coefs470_all_tp)) deallocate(coefs470_all_tp)
4745  !allocate (coefs470_all_tp(LERedge(1),LERedge(2),4,3,2), stat = checkvariable)
4746  !if ( checkvariable /= 0 ) goto 90
4747 
4748  !if (allocated(coefs470_fwd_tp)) deallocate(coefs470_fwd_tp)
4749  !allocate (coefs470_fwd_tp(LERedge(1),LERedge(2),4,3,2), stat = checkvariable)
4750  !if ( checkvariable /= 0 ) goto 90
4751 
4752  if (allocated(coefs470_all)) deallocate(coefs470_all)
4753  allocate (coefs470_all(leredge(1),leredge(2),4,3), stat = checkvariable)
4754  if ( checkvariable /= 0 ) goto 90
4755 
4756  if (allocated(coefs470_fwd)) deallocate(coefs470_fwd)
4757  allocate (coefs470_fwd(leredge(1),leredge(2),4,3), stat = checkvariable)
4758  if ( checkvariable /= 0 ) goto 90
4759 
4760  !if (allocated(coefs650_all_tp)) deallocate(coefs650_all_tp)
4761  !allocate (coefs650_all_tp(LERedge(1),LERedge(2),4,3,2), stat = checkvariable)
4762  !if ( checkvariable /= 0 ) goto 90
4763 
4764  !if (allocated(coefs650_fwd_tp)) deallocate(coefs650_fwd_tp)
4765  !allocate (coefs650_fwd_tp(LERedge(1),LERedge(2),4,3,2), stat = checkvariable)
4766  !if ( checkvariable /= 0 ) goto 90
4767 
4768  if (allocated(coefs650_all)) deallocate(coefs650_all)
4769  allocate (coefs650_all(leredge(1),leredge(2),4,3), stat = checkvariable)
4770  if ( checkvariable /= 0 ) goto 90
4771 
4772  if (allocated(coefs650_fwd)) deallocate(coefs650_fwd)
4773  allocate (coefs650_fwd(leredge(1),leredge(2),4,3), stat = checkvariable)
4774  if ( checkvariable /= 0 ) goto 90
4775 
4776 ! -- allocate arrays for VIIRS, all-angle surface database
4777  if (allocated(vgref412_all)) deallocate(vgref412_all)
4778  allocate (vgref412_all(leredge(1),leredge(2)), stat = checkvariable)
4779  if ( checkvariable /= 0 ) goto 90
4780 
4781  if (allocated(vgref488_all)) deallocate(vgref488_all)
4782  allocate (vgref488_all(leredge(1),leredge(2)), stat = checkvariable)
4783  if ( checkvariable /= 0 ) goto 90
4784 
4785  if (allocated(vgref670_all)) deallocate(vgref670_all)
4786  allocate (vgref670_all(leredge(1),leredge(2)), stat = checkvariable)
4787  if ( checkvariable /= 0 ) goto 90
4788 
4789  goto 100
4790 
4791 90 continue
4792  print *, "ERROR: Unable to allocate coefficient array: ", status
4793  return
4794 
4795 100 continue
4796  return
4797 
4798  end function set_limits
4799 
4800 ! -- Find granule limits and set offsets for 2.2 um surface database, and allocate space for the
4801 ! tables, 0.06 degree resolution
4802  integer function set_limits6(locedge, lat, long) RESULT(status)
4803 
4804  integer, intent(in) :: locedge(2)
4805  real, intent(in) :: lat(locedge(1),locedge(2)), long(locedge(1),locedge(2))
4806 
4807  integer :: checkvariable
4808  integer :: i, j
4809  character (len=256) :: msg
4810  real :: eastedge, westedge
4811  status = 0
4812 
4813 ! -- if processing extracts, if region of interest is within bounds of the
4814 ! granule,
4815 ! -- but not actually contained in the granule quadralateral, lat and lon
4816 ! values may be
4817 ! -- set to fill values (-999). Check this condition and fail.
4818 ! -- @TODO - utilize the status variable and check where called.
4819 ! if (minval(lat) < -900.0 .OR. minval(long) < -900.0) then
4820 ! msg = "Min lat or min lon is fill value. Failing."
4821 ! call MODIS_SMF_SETDYNAMICMSG(MODIS_F_GENERIC, msg, 'set_limits')
4822 ! end if
4823 
4824  eastedge = -999.0
4825  westedge = 999.0
4826  dateline6 = 0
4827  if (minval(long, long > -900.0) < -175.0 .and. maxval(long, long > -900.0) > 175.0) then
4828  eastedge = 180.0
4829  westedge = -180.0
4830  do i=1, locedge(1)
4831  do j=1, locedge(2)
4832  if (long(i,j) < -900.0) cycle ! skip undefined
4833  if (long(i,j) > 0.0 .and. long(i,j) < eastedge) eastedge = long(i,j)
4834  if (long(i,j) < 0.0 .and. long(i,j) > westedge) westedge = long(i,j)
4835  enddo
4836  enddo
4837  lerstart6(1) = (180+(floor(eastedge)-1))/0.06
4838  if (lerstart6(1) .le. 0) lerstart6(1) = 1
4839  dateline6 = 6000 - lerstart6(1)
4840  leredge6(1) = (180+(floor(westedge)+2))/0.06 + dateline6
4841  else
4842  lerstart6(1) = (180+(floor(minval(long, long > -900.0))-1))/0.06
4843  if (lerstart6(1) .le. 0) lerstart6(1) = 1
4844  leredge6(1) = (180+(floor(maxval(long, long > -900.0))+2))/0.06 - lerstart6(1)
4845  if (leredge6(1)+lerstart6(1) > 6000) leredge6(1) = 6000 - lerstart6(1)
4846  endif
4847 
4848  lerstart6(2) = (90+(floor(minval(lat, lat > -900.0))-1))/0.06
4849  if (lerstart6(2) .le. 0) lerstart6(2) = 1
4850  leredge6(2) = (90+(floor(maxval(lat, lat > -900.0))+2))/0.06 - lerstart6(2)
4851  if (leredge6(2)+lerstart6(2) > 3000) leredge6(2) = 3000 - lerstart6(2)
4852 
4853  if (allocated(swir_coeffs412)) deallocate(swir_coeffs412)
4854  allocate (swir_coeffs412(leredge6(1),leredge6(2),3), stat = checkvariable)
4855  if ( checkvariable /= 0 ) goto 90
4856 
4857  if (allocated(swir_coeffs470)) deallocate(swir_coeffs470)
4858  allocate (swir_coeffs470(leredge6(1),leredge6(2),3), stat = checkvariable)
4859  if ( checkvariable /= 0 ) goto 90
4860 
4861  if (allocated(swir_stderr412)) deallocate(swir_stderr412)
4862  allocate (swir_stderr412(leredge6(1),leredge6(2)), stat = checkvariable)
4863  if ( checkvariable /= 0 ) goto 90
4864 
4865  if (allocated(swir_stderr470)) deallocate(swir_stderr470)
4866  allocate (swir_stderr470(leredge6(1),leredge6(2)), stat = checkvariable)
4867  if ( checkvariable /= 0 ) goto 90
4868 
4869  if (allocated(swir_min)) deallocate(swir_min)
4870  allocate (swir_min(leredge6(1),leredge6(2)), stat = checkvariable)
4871  if ( checkvariable /= 0 ) goto 90
4872 
4873  if (allocated(swir_max)) deallocate(swir_max)
4874  allocate (swir_max(leredge6(1),leredge6(2)), stat = checkvariable)
4875  if ( checkvariable /= 0 ) goto 90
4876 
4877  goto 100
4878 
4879 90 continue
4880  print *, "ERROR: Unable to allocate 2.2 um surface database array: ", status
4881  return
4882 
4883 100 continue
4884  return
4885 
4886  end function set_limits6
4887 
4888 ! -- Load surface LER coefficient tables.
4889  integer function load_hdfler(lut_file, season) RESULT(status)
4890 
4891 ! include 'hdf.f90'
4892 ! include 'dffunc.f90'
4893  use netcdf
4894 
4895  character(len=255), intent(in) :: lut_file
4896  integer, intent(in) :: season
4897 
4898  integer :: start2(3), stride2(3), edges2(3)
4899  integer :: start4(5), stride4(5), edge4(5)
4900 
4901  character(len=255) :: sds_name
4902  character(len=255) :: dset_name
4903  character(len=255) :: test_name
4904  character(len=255) :: group_name
4905 
4906  integer :: nc_id
4907  integer :: dim_id
4908  integer :: dset_id
4909  integer :: grp_id
4910  integer :: sd_id, sds_index, sds_id
4911 
4912  start2 = (/lerstart(1),lerstart(2),season/)
4913  edges2 = (/leredge(1),leredge(2),1/)
4914  stride2 = (/1,1,1/)
4915 
4916  start4 = (/lerstart(1),lerstart(2),1,1,season/)
4917  edge4 = (/leredge(1),leredge(2),4,3,1/)
4918  stride4 = (/1,1,1,1,1/)
4919 
4920  test_name = trim(lut_file)
4921  status = nf90_open(test_name, nf90_nowrite, nc_id)
4922  if (status /= nf90_noerr) then
4923  print *, "ERROR: Failed to open deepblue lut_nc4 file: ", status
4924  return
4925  end if
4926 
4927  group_name = 'SURFACE_COEFFICIENTS'
4928  status = nf90_inq_ncid(nc_id, group_name, grp_id)
4929  if (status /= nf90_noerr) then
4930  print *, "ERROR: Failed to get ID of group "//trim(group_name)//": ", status
4931  return
4932  end if
4933 
4934  !sds_name = "412_fwd_TP"
4935  !status = readLER5(start5, edge5, stride5, sds_name, grp_id, coefs412_fwd_tp)
4936  !if (status < 0) goto 90
4937 
4938  !sds_name = "412_all_TP"
4939  !status = readLER5(start5, edge5, stride5, sds_name, grp_id, coefs412_all_tp)
4940  !if (status < 0) goto 90
4941 
4942  sds_name = "SC412_FWD"
4943  status = readler5(start4, edge4, stride4, sds_name, grp_id, coefs412_fwd)
4944  if (status < 0) goto 90
4945 
4946  sds_name = "SC412_ALL"
4947  status = readler5(start4, edge4, stride4, sds_name, grp_id, coefs412_all)
4948  if (status < 0) goto 90
4949 
4950  !sds_name = "470_fwd_TP"
4951  !status = readLER5(start5, edge5, stride5, sds_name, grp_id, coefs470_fwd_tp)
4952  !if (status < 0) goto 90
4953 
4954  !sds_name = "470_all_TP"
4955  !status = readLER5(start5, edge5, stride5, sds_name, grp_id, coefs470_all_tp)
4956  !if (status < 0) goto 90
4957 
4958  sds_name = "SC470_FWD"
4959  status = readler5(start4, edge4, stride4, sds_name, grp_id, coefs470_fwd)
4960  if (status < 0) goto 90
4961 
4962  sds_name = "SC470_ALL"
4963  status = readler5(start4, edge4, stride4, sds_name, grp_id, coefs470_all)
4964  if (status < 0) goto 90
4965 
4966  !sds_name = "650_fwd_TP"
4967  !status = readLER5(start5, edge5, stride5, sds_name, grp_id, coefs650_fwd_tp)
4968  !if (status < 0) goto 90
4969 
4970  !sds_name = "650_all_TP"
4971  !status = readLER5(start5, edge5, stride5, sds_name, grp_id, coefs650_all_tp)
4972  !if (status < 0) goto 90
4973 
4974  sds_name = "SC650_FWD"
4975  status = readler5(start4, edge4, stride4, sds_name, grp_id, coefs650_fwd)
4976  if (status < 0) goto 90
4977 
4978  sds_name = "SC650_ALL"
4979  status = readler5(start4, edge4, stride4, sds_name, grp_id, coefs650_all)
4980  if (status < 0) goto 90
4981 
4982  status = nf90_close(nc_id)
4983  if (status /= nf90_noerr) then
4984  print *, "ERROR: Failed to close lut_nc4 file: ", status
4985  return
4986  end if
4987 
4988 ! -- MODIS, all-angle surface database
4989  status = nf90_open(trim(lut_file), nf90_nowrite, nc_id)
4990  if (status /= nf90_noerr) then
4991  print *, "ERROR: Failed to open deepblue lut_nc4 file: ", status
4992  return
4993  end if
4994 
4995  group_name = 'MODIS_SURFACE_REFLECTANCE'
4996  status = nf90_inq_ncid(nc_id, group_name, grp_id)
4997  if (status /= nf90_noerr) then
4998  print *, "ERROR: Failed to get ID of group "//trim(group_name)//": ", status
4999  return
5000  end if
5001 
5002  sds_name = "SR412_ALL"
5003  status = readler2(start2, edges2, stride2, sds_name, grp_id, gref412_all)
5004  if (status < 0) goto 90
5005 
5006  sds_name = "SR412_FWD"
5007  status = readler2(start2, edges2, stride2, sds_name, grp_id, gref412_fwd)
5008  if (status < 0) goto 90
5009 
5010  !sds_name = "412_bkd"
5011  !status = readLER2(start2, edges2, stride2, sds_name, grp_id, gref412_bkd)
5012  !if (status < 0) goto 90
5013 
5014  sds_name = "SR470_ALL"
5015  status = readler2(start2, edges2, stride2, sds_name, grp_id, gref470_all)
5016  if (status < 0) goto 90
5017 
5018  sds_name = "SR470_FWD"
5019  status = readler2(start2, edges2, stride2, sds_name, grp_id, gref470_fwd)
5020  if (status < 0) goto 90
5021 
5022  !sds_name = "470_bkd"
5023  !status = readLER2(start2, edges2, stride2, sds_name, grp_id, gref470_bkd)
5024  !if (status < 0) goto 90
5025 
5026  sds_name = "SR650_ALL"
5027  status = readler2(start2, edges2, stride2, sds_name, grp_id, gref650_all)
5028  if (status < 0) goto 90
5029 
5030  sds_name = "SR650_FWD"
5031  status = readler2(start2, edges2, stride2, sds_name, grp_id, gref650_fwd)
5032  if (status < 0) goto 90
5033 
5034  !sds_name = "650_bkd"
5035  !status = readLER2(start2, edges2, stride2, sds_name, grp_id, gref650_bkd)
5036  !if (status < 0) goto 90
5037 
5038  sds_name = "SR865_ALL"
5039  status = readler2(start2, edges2, stride2, sds_name, grp_id, gref865_all)
5040  if (status < 0) goto 90
5041 
5042  status = nf90_close(nc_id)
5043  if (status /= nf90_noerr) then
5044  print *, "ERROR: Failed to close lut_nc4 file: ", status
5045  return
5046  end if
5047 
5048 ! -- VIIRS, all-angle surface database
5049  status = nf90_open(trim(lut_file), nf90_nowrite, nc_id)
5050  if (status /= nf90_noerr) then
5051  print *, "ERROR: Failed to open deepblue lut_nc4 file: ", status
5052  return
5053  end if
5054 
5055  group_name = 'VIIRS_SURFACE_REFLECTANCE'
5056  status = nf90_inq_ncid(nc_id, group_name, grp_id)
5057  if (status /= nf90_noerr) then
5058  print *, "ERROR: Failed to get ID of group "//trim(group_name)//": ", status
5059  return
5060  end if
5061 
5062 
5063 
5064  sds_name = "SR412_ALL"
5065  status = readler2(start2, edges2, stride2, sds_name, grp_id, vgref412_all)
5066  if (status < 0) goto 90
5067 
5068  sds_name = "SR488_ALL"
5069  status = readler2(start2, edges2, stride2, sds_name, grp_id, vgref488_all)
5070  if (status < 0) goto 90
5071 
5072  sds_name = "SR670_ALL"
5073  status = readler2(start2, edges2, stride2, sds_name, grp_id, vgref670_all)
5074  if (status < 0) goto 90
5075 
5076  status = nf90_close(nc_id)
5077  if (status /= nf90_noerr) then
5078  print *, "ERROR: Failed to close lut_nc4 file: ", status
5079  return
5080  end if
5081 
5082  ! Close up shop and go home
5083  goto 100
5084 
5085 90 continue
5086  print *, "Error reading "//trim(sds_name)//" from file "//trim(lut_file)
5087  return
5088 100 continue
5089 
5090  end function load_hdfler
5091 
5092 ! -- Load 2.2 um surface database
5093  integer function load_swir_coeffs(file, season) result(status) !jlee added 05/16/2017
5094 
5095 ! include 'hdf.f90'
5096 ! include 'dffunc.f90'
5097  use netcdf
5098 
5099  implicit none
5100 
5101  character(len=255), intent(in) :: file
5102  integer, intent(in) :: season
5103 
5104  ! HDF vars
5105  character(len=255) :: sds_name
5106  character(len=255) :: dset_name
5107  character(len=255) :: attr_name
5108  character(len=255) :: group_name
5109 
5110  integer :: nc_id
5111  integer :: dim_id
5112  integer :: dset_id
5113  integer :: grp_id
5114  integer :: sd_id, sds_index, sds_id
5115  integer, dimension(3) :: start2, stride2, edges2
5116  integer, dimension(4) :: start3, stride3, edges3
5117 
5118  status = -1
5119 
5120  start2 = (/lerstart6(1),lerstart6(2),season/)
5121  edges2 = (/leredge6(1),leredge6(2),1/)
5122  stride2 =(/1,1,1/)
5123 
5124  start3 = (/lerstart6(1),lerstart6(2),1,season/)
5125  edges3 = (/leredge6(1),leredge6(2),3,1/)
5126  stride3 =(/1,1,1,1/)
5127 
5128  status = nf90_open(file, nf90_nowrite, nc_id)
5129  if (status /= nf90_noerr) then
5130  print *, "ERROR: Failed to open deepblue lut_nc4 file: ", status
5131  return
5132  end if
5133 
5134  group_name = 'SWIR_VS_VISIBLE'
5135  status = nf90_inq_ncid(nc_id, group_name, grp_id)
5136  if (status /= nf90_noerr) then
5137  print *, "ERROR: Failed to get ID of group "//trim(group_name)//": ", status
5138  return
5139  end if
5140 
5141  sds_name = 'coeffs_2250_to_412'
5142  status = readswir3(start3, edges3, stride3, sds_name, grp_id, swir_coeffs412)
5143  if (status < 0) goto 90
5144  !============================================================================
5145  sds_name = 'stderr_412'
5146  status = readswir2(start2, edges2, stride2, sds_name, grp_id, swir_stderr412)
5147  if (status < 0) goto 90
5148  !============================================================================
5149  sds_name = 'coeffs_2250_to_488'
5150  status = readswir3(start3, edges3, stride3, sds_name, grp_id, swir_coeffs470)
5151  if (status < 0) goto 90
5152  !============================================================================
5153  sds_name = 'stderr_488'
5154  status = readswir2(start2, edges2, stride2, sds_name, grp_id, swir_stderr470)
5155  if (status < 0) goto 90
5156  !============================================================================
5157  sds_name = 'min_2250_for_488'
5158  status = readswir2(start2, edges2, stride2, sds_name, grp_id, swir_min)
5159  if (status < 0) goto 90
5160  !============================================================================
5161  sds_name = 'max_2250_for_488'
5162  status = readswir2(start2, edges2, stride2, sds_name, grp_id, swir_max)
5163  if (status < 0) goto 90
5164  !============================================================================
5165 
5166  status = nf90_close(nc_id)
5167  if (status /= nf90_noerr) then
5168  print *, "ERROR: Failed to close lut_nc4 file: ", status
5169  return
5170  end if
5171 
5172  goto 100
5173 
5174 90 continue
5175  print *, "Error reading "//trim(sds_name)//" from file "//trim(file)
5176  return
5177 
5178 100 continue
5179 
5180  end function load_swir_coeffs
5181 
5182 
5183 ! Retrieve swir vs. vis coefficients
5184  function get_swir_coeffs412(latidx, lonidx)
5185  integer, intent(in) :: latidx, lonidx
5186  integer :: i,j
5187  real :: get_swir_coeffs412(3)
5188 
5189  if (dateline6 .eq. 0 .OR. lonidx .gt. lerstart6(1)) then
5190  i = lonidx - lerstart6(1)
5191  else
5192  i = lonidx + dateline6
5193  end if
5194  j = latidx - lerstart6(2)
5195 
5196  get_swir_coeffs412 = swir_coeffs412(i,j,:)
5197 
5198  end function
5199 
5200 ! Retrieve swir vs. vis coefficients
5201  function get_swir_coeffs470(latidx, lonidx)
5202  integer, intent(in) :: latidx, lonidx
5203  integer :: i,j
5204  real :: get_swir_coeffs470(3)
5205 
5206  if (dateline6 .eq. 0 .OR. lonidx .gt. lerstart6(1)) then
5207  i = lonidx - lerstart6(1)
5208  else
5209  i = lonidx + dateline6
5210  end if
5211  j = latidx - lerstart6(2)
5212 
5213  get_swir_coeffs470 = swir_coeffs470(i,j,:)
5214 
5215  end function
5216 
5217 ! Retrieve swir vs. vis stderr
5218  real function get_swir_stderr412(latidx, lonidx) result(stderr)
5219  integer, intent(in) :: latidx, lonidx
5220  integer :: i,j
5221 
5222  if (dateline6 .eq. 0 .OR. lonidx .gt. lerstart6(1)) then
5223  i = lonidx - lerstart6(1)
5224  else
5225  i = lonidx + dateline6
5226  end if
5227  j = latidx - lerstart6(2)
5228 
5229  stderr = swir_stderr412(i,j)
5230 
5231  end function get_swir_stderr412
5232 
5233 ! Retrieve swir vs. vis stderr
5234  real function get_swir_stderr470(latidx, lonidx) result(stderr)
5235  integer, intent(in) :: latidx, lonidx
5236  integer :: i,j
5237 
5238  if (dateline6 .eq. 0 .OR. lonidx .gt. lerstart6(1)) then
5239  i = lonidx - lerstart6(1)
5240  else
5241  i = lonidx + dateline6
5242  end if
5243  j = latidx - lerstart6(2)
5244 
5245  stderr = swir_stderr470(i,j)
5246 
5247  end function get_swir_stderr470
5248 
5249 ! Retrieve swir vs. vis min-max range
5250  function get_swir_range(latidx, lonidx)
5251  integer, intent(in) :: latidx, lonidx
5252  integer :: i,j
5253  real :: get_swir_range(2)
5254 
5255  if (dateline6 .eq. 0 .OR. lonidx .gt. lerstart6(1)) then
5256  i = lonidx - lerstart6(1)
5257  else
5258  i = lonidx + dateline6
5259  end if
5260  j = latidx - lerstart6(2)
5261 
5262  get_swir_range = (/swir_min(i,j),swir_max(i,j)/)
5263 
5264  end function
5265 
5266 ! Retrieve LER865 value
5267  real function get_ler865(latidx, lonidx) result(ler)
5268  integer, intent(in) :: latidx, lonidx
5269 
5270  integer :: i,j
5271 
5272  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
5273  i = lonidx - lerstart(1)
5274  else
5275  i = lonidx + dateline
5276  end if
5277  j = latidx - lerstart(2)
5278 
5279  ler = gref865_all(i,j)
5280 
5281  end function get_ler865
5282 
5283 ! -- Retrieve LER412 value from surface reflectivity coefficient table for pixel at
5284 ! -- latidx, lonidx in table.
5285  real function get_ler412(latidx, lonidx, ndvi, scatangle, relaz) result(ler)
5286  integer, intent(in) :: latidx, lonidx
5287  real, intent(in) :: ndvi, scatangle, relaz
5288 
5289  integer :: i,j,nidx
5290  real :: coefs(4), acoefs(4), ncoefs(4), mcoefs(4), tler
5291 
5292  ler = -999.0
5293  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
5294  i = lonidx - lerstart(1)
5295  else
5296  i = lonidx + dateline
5297  end if
5298  j = latidx - lerstart(2)
5299 
5300 ! print *,"in get_LER412"
5301 ! print *,"latidx, lonidx = ",latidx, lonidx
5302 ! print *,"i,j = ",i,j
5303 ! print *,"LERstart = ",LERstart
5304 ! print *,"LERedge = ",LERedge
5305 
5306  if (ndvi < ndvi1_cutoff) then
5307  nidx = 1
5308  elseif (ndvi < ndvi2_cutoff) then
5309  nidx = 2
5310  else
5311  nidx = 3
5312  endif
5313 
5314  if (relaz < 90.0) then
5315  !ncoefs(:) = coefs412_fwd_tp(i,j,:,nidx,1)
5316  !acoefs(:) = coefs412_fwd_tp(i,j,:,1,1)
5317  !mcoefs(:) = coefs412_fwd_tp(i,j,:,1,2)
5318  ncoefs(:) = coefs412_fwd(i,j,:,nidx)
5319  !acoefs(:) = coefs412_fwd(i,j,:,1,1)
5320  !mcoefs(:) = coefs412_fwd(i,j,:,1,2)
5321  tler = vgref412_all(i,j)!if there is no BRDF value, use VIIRS min ref (Jul 2017 W.KIM)
5322  else
5323  !ncoefs(:) = coefs412_all_tp(i,j,:,nidx,1)
5324  !acoefs(:) = coefs412_all_tp(i,j,:,1,1)
5325  !mcoefs(:) = coefs412_all_tp(i,j,:,1,2)
5326  ncoefs(:) = coefs412_all(i,j,:,nidx)
5327  !acoefs(:) = coefs412_all(i,j,:,1,1)
5328  !mcoefs(:) = coefs412_all(i,j,:,1,2)
5329  tler = vgref412_all(i,j)!if there is no BRDF value, use VIIRS min ref (Jul 2017 W.KIM)
5330  endif
5331 
5332  !print *,"relaz = ",relaz,NDVI
5333  !coefs(:) = ncoefs(:)
5334  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5335  !print *,"ncoefs = ",ncoefs, LER
5336  !coefs(:) = acoefs(:)
5337  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5338  !print *,"acoefs = ",acoefs, LER
5339  !coefs(:) = mcoefs(:)
5340  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5341  !print *,"mcoefs = ",mcoefs, LER
5342  !print *,"tLER = ",tLER
5343 
5344  if (maxval(ncoefs) > 0.0) then
5345  coefs(:) = ncoefs(:)
5346 ! elseif (maxval(acoefs) > 0.0) then
5347 ! coefs(:) = acoefs(:)
5348 ! elseif (maxval(mcoefs) > 0.0) then
5349 ! coefs(:) = mcoefs(:)
5350  else
5351  coefs(:) = -999.0
5352  endif
5353 
5354  if (maxval(coefs) > 0.0) then
5355  ler = coefs(1) + scatangle*(coefs(2) + scatangle*(coefs(3) + scatangle*coefs(4)))
5356  endif
5357 
5358  if (ler < 0.0) then
5359  ler = tler
5360  endif
5361 
5362  end function get_ler412
5363 
5364 ! -- Retrieve LER470 value from surface reflectivity coefficient table for pixel at
5365 ! -- latidx, lonidx in table.
5366  real function get_ler470(latidx, lonidx, ndvi, scatangle, relaz) result(ler)
5367  integer, intent(in) :: latidx, lonidx
5368  real, intent(in) :: ndvi, scatangle, relaz
5369 
5370  integer :: i,j,nidx
5371  real :: coefs(4), acoefs(4), ncoefs(4), mcoefs(4), tler
5372 
5373  ler = -999.0
5374  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
5375  i = lonidx - lerstart(1)
5376  else
5377  i = lonidx + dateline
5378  end if
5379  j = latidx - lerstart(2)
5380 
5381  !print *,"in get_LER470"
5382  !print *,"latidx, lonidx = ",latidx, lonidx
5383  !print *,"i,j = ",i,j
5384  !print *,"LERstart = ",LERstart
5385  !print *,"LERedge = ",LERedge
5386 
5387  if (ndvi < ndvi1_cutoff) then
5388  nidx = 1
5389  elseif (ndvi < ndvi2_cutoff) then
5390  nidx = 2
5391  else
5392  nidx = 3
5393  endif
5394 
5395  acoefs(:) = -999.0
5396  mcoefs(:) = -999.0
5397  ncoefs(:) = -999.0
5398  if (relaz < 90.0) then
5399  !ncoefs(:) = coefs470_fwd_tp(i,j,:,nidx,1)
5400  !acoefs(:) = coefs470_fwd_tp(i,j,:,1,1)
5401  !coefs(:) = coefs470_fwd_tp(i,j,:,1,2)
5402  ncoefs(:) = coefs470_fwd(i,j,:,nidx)
5403  !acoefs(:) = coefs470_fwd(i,j,:,1,1)
5404  !mcoefs(:) = coefs470_fwd(i,j,:,1,2)
5405  tler = vgref488_all(i,j)!if there is no BRDF value, use VIIRS min ref (Jul 2017 W.KIM)
5406  else
5407  !ncoefs(:) = coefs470_all_tp(i,j,:,nidx,1)
5408  !acoefs(:) = coefs470_all_tp(i,j,:,1,1)
5409  !mcoefs(:) = coefs470_all_tp(i,j,:,1,2)
5410  ncoefs(:) = coefs470_all(i,j,:,nidx)
5411  !acoefs(:) = coefs470_all(i,j,:,1,1)
5412  !mcoefs(:) = coefs470_all(i,j,:,1,2)
5413  tler = vgref488_all(i,j)!if there is no BRDF value, use VIIRS min ref (Jul 2017 W.KIM)
5414  endif
5415 
5416  !print *,"relaz = ",relaz,NDVI
5417  !coefs(:) = ncoefs(:)
5418  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5419  !print *,"ncoefs = ",ncoefs, LER
5420  !coefs(:) = acoefs(:)
5421  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5422  !print *,"acoefs = ",acoefs, LER
5423  !coefs(:) = mcoefs(:)
5424  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5425  !print *,"mcoefs = ",mcoefs, LER
5426  !print *,"tLER = ",tLER
5427 
5428  if (maxval(ncoefs) > 0.0) then
5429  coefs(:) = ncoefs(:)
5430  elseif (maxval(acoefs) > 0.0) then
5431  coefs(:) = acoefs(:)
5432  elseif (maxval(mcoefs) > 0.0) then
5433  coefs(:) = mcoefs(:)
5434  else
5435  coefs(:) = -999.0
5436  endif
5437 
5438  if (maxval(coefs) > 0.0) then
5439  ler = coefs(1) + scatangle*(coefs(2) + scatangle*(coefs(3) + scatangle*coefs(4)))
5440  endif
5441 
5442  if (ler < 0.0) then
5443  ler = tler
5444  endif
5445 
5446  end function get_ler470
5447 
5448 ! -- Retrieve LER650 value from surface reflectivity coefficient table for pixel at
5449 ! -- latidx, lonidx in table.
5450  real function get_ler650(latidx, lonidx, ndvi, scatangle, relaz) result(ler)
5451  integer, intent(in) :: latidx, lonidx
5452  real, intent(in) :: ndvi, scatangle, relaz
5453 
5454  integer :: i,j,nidx
5455  real :: coefs(4), acoefs(4), ncoefs(4), mcoefs(4), tler
5456 
5457  ler = -999.0
5458  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
5459  i = lonidx - lerstart(1)
5460  else
5461  i = lonidx + dateline
5462  end if
5463  j = latidx - lerstart(2)
5464 
5465 ! print *,"in get_LER650"
5466 ! print *,"latidx, lonidx = ",latidx, lonidx
5467 ! print *,"i,j = ",i,j
5468 ! print *,"LERstart = ",LERstart
5469 ! print *,"LERedge = ",LERedge
5470 ! print *,"dateline = ", dateline
5471 
5472  if (ndvi < ndvi1_cutoff) then
5473  nidx = 1
5474  elseif (ndvi < ndvi2_cutoff) then
5475  nidx = 2
5476  else
5477  nidx = 3
5478  endif
5479 
5480  if (relaz < 90.0) then
5481  !ncoefs(:) = coefs650_fwd_tp(i,j,:,nidx,1)
5482  !acoefs(:) = coefs650_fwd_tp(i,j,:,1,1)
5483  !mcoefs(:) = coefs650_fwd_tp(i,j,:,1,2)
5484  ncoefs(:) = coefs650_fwd(i,j,:,nidx)
5485  !acoefs(:) = coefs650_fwd(i,j,:,1)
5486  !mcoefs(:) = coefs650_fwd(i,j,:,1)
5487  tler = vgref670_all(i,j)!if there is no BRDF value, use VIIRS min ref (Jul 2017 W.KIM)
5488  else
5489  !ncoefs(:) = coefs650_all_tp(i,j,:,nidx,1)
5490  !acoefs(:) = coefs650_all_tp(i,j,:,1,1)
5491  !mcoefs(:) = coefs650_all_tp(i,j,:,1,2)
5492  ncoefs(:) = coefs650_all(i,j,:,nidx)
5493  !acoefs(:) = coefs650_all(i,j,:,1,1)
5494  !mcoefs(:) = coefs650_all(i,j,:,1,2)
5495  tler = vgref670_all(i,j)!if there is no BRDF value, use VIIRS min ref (Jul 2017 W.KIM)
5496  endif
5497 
5498  !print *,"relaz = ",relaz,NDVI
5499  !coefs(:) = ncoefs(:)
5500  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5501  !print *,"ncoefs = ",ncoefs, LER
5502  !coefs(:) = acoefs(:)
5503  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5504  !print *,"acoefs = ",acoefs, LER
5505  !coefs(:) = mcoefs(:)
5506  !LER = coefs(1) + scatAngle*(coefs(2) + scatAngle*(coefs(3) + scatAngle*coefs(4)))
5507  !print *,"mcoefs = ",mcoefs, LER
5508  !print *,"tLER = ",tLER
5509 
5510  if (maxval(ncoefs) > 0.0) then
5511  coefs(:) = ncoefs(:)
5512 ! elseif (maxval(acoefs) > 0.0) then
5513 ! coefs(:) = acoefs(:)
5514 ! elseif (maxval(mcoefs) > 0.0) then
5515 ! coefs(:) = mcoefs(:)
5516  else
5517  coefs(:) = -999.0
5518  endif
5519 
5520  if (maxval(coefs) > 0.0) then
5521  ler = coefs(1) + scatangle*(coefs(2) + scatangle*(coefs(3) + scatangle*coefs(4)))
5522  endif
5523 
5524  if (ler < 0.0) then
5525  ler = tler
5526  endif
5527 
5528  end function get_ler650
5529 
5530  ! Read in LER tables
5531  integer function readler2(start, edge, stride, sds_name, grp_id, outref) RESULT(status)
5532 
5533 ! include 'hdf.f90'
5534 ! include 'dffunc.f90'
5535  use netcdf
5536 
5537  implicit none
5538 
5539  integer, dimension(3), intent(in) :: start, edge, stride
5540  integer, intent(in) :: grp_id
5541  real, intent(out) :: outref(edge(1),edge(2))
5542 
5543  ! HDF vars
5544  character(len=255) :: sds_name
5545  character(len=255) :: dset_name
5546  character(len=255) :: attr_name
5547  character(len=255) :: group_name
5548 
5549  integer :: nc_id
5550  integer :: dim_id
5551  integer :: dset_id
5552  integer :: sds_index, sds_id
5553  integer, dimension(3) :: tmpedge, tmpstart
5554  real, dimension(:,:), allocatable :: tmpout
5555 
5556  dset_name = sds_name
5557  status = nf90_inq_varid(grp_id, dset_name, dset_id)
5558  if (status /= nf90_noerr) then
5559  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
5560  return
5561  end if
5562 
5563  if (dateline .eq. 0) then
5564  status = nf90_get_var(grp_id, dset_id, outref, start=start, &
5565  stride=stride, count=edge)
5566  if (status /= nf90_noerr) then
5567  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5568  return
5569  end if
5570  else
5571  ! The granule straddles the dateline, so we need to make an accommodation
5572  tmpedge(:) = edge(:)
5573  tmpedge(1) = dateline
5574  allocate(tmpout(tmpedge(1), tmpedge(2)), stat=status)
5575  if (status /= 0) then
5576  print *, "ERROR: Unable to allocate tmpedge: ", status
5577  return
5578  end if
5579  status = nf90_get_var(grp_id, dset_id, tmpout, start=start, &
5580  stride=stride, count=tmpedge)
5581  if (status /= nf90_noerr) then
5582  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5583  return
5584  end if
5585  outref(1:dateline, :) = tmpout
5586 
5587  deallocate(tmpout, stat=status)
5588  if (status /= 0) then
5589  print *, "Failed to deallocate tmpout: ", status
5590  return
5591  end if
5592 
5593  tmpstart(:) = start(:)
5594  tmpstart(1) = 1
5595  tmpedge(1) = edge(1) - dateline
5596  allocate(tmpout(tmpedge(1), tmpedge(2)), stat=status)
5597  if (status /= 0) then
5598  print *, "ERROR: Unable to allocate tmpedge: ", status
5599  return
5600  end if
5601  status = nf90_get_var(grp_id, dset_id, tmpout, start=tmpstart, &
5602  stride=stride, count=tmpedge)
5603  if (status /= nf90_noerr) then
5604  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5605  return
5606  end if
5607  outref(dateline+1:edge(1),:) = tmpout
5608 
5609  deallocate(tmpout, stat=status)
5610  if (status /= 0) then
5611  print *, "Failed to deallocate tmpout: ", status
5612  return
5613  end if
5614  end if
5615 
5616  return
5617  end function readler2
5618 
5619  ! Read in LER tables
5620  integer function readler5(start, edge, stride, sds_name, grp_id, outref) RESULT(status)
5621 
5622 ! include 'hdf.f90'
5623 ! include 'dffunc.f90'
5624  use netcdf
5625 
5626  implicit none
5627 
5628  integer, dimension(:), intent(in) :: start, edge, stride
5629  character(len=255), intent(in) :: sds_name
5630  integer, intent(in) :: grp_id
5631  real, dimension(:,:,:,:), intent(inout) :: outref
5632 
5633  ! HDF vars
5634  character(len=255) :: dset_name
5635 
5636  integer :: nc_id
5637  integer :: dim_id
5638  integer :: dset_id
5639  integer :: sds_index, sds_id
5640  integer, dimension(5) :: tmpedge, tmpstart
5641  real, dimension(:,:,:,:), allocatable :: tmpout
5642  character(len=255) :: tmp_name
5643  integer :: rank, ntype, nattrs
5644  integer, dimension(5) :: dims
5645 
5646  status = -1
5647 
5648  dset_name = sds_name
5649  status = nf90_inq_varid(grp_id, dset_name, dset_id)
5650  if (status /= nf90_noerr) then
5651  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
5652  return
5653  end if
5654 
5655  if (dateline .eq. 0) then
5656 
5657  status = nf90_get_var(grp_id, dset_id, outref, start=start, &
5658  stride=stride, count=edge)
5659  if (status /= nf90_noerr) then
5660  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5661  return
5662  end if
5663  else
5664  ! The granule straddles the dateline, so we need to make an accommodation
5665  tmpedge(:) = edge(:)
5666  tmpedge(1) = dateline
5667  allocate(tmpout(tmpedge(1), tmpedge(2), tmpedge(3), tmpedge(4)), stat=status)
5668  if (status /= 0) then
5669  print *, "ERROR: Unable to allocate tmpedge: ", status
5670  return
5671  end if
5672  status = nf90_get_var(grp_id, dset_id, tmpout, start=start, &
5673  stride=stride, count=tmpedge)
5674  if (status /= nf90_noerr) then
5675  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5676  return
5677  end if
5678  outref(1:dateline, :, :, :) = tmpout(:,:,:,:)
5679 
5680  deallocate(tmpout, stat=status)
5681  if (status /= 0) then
5682  print *, "Failed to deallocate tmpout: ", status
5683  return
5684  end if
5685 
5686  tmpstart(:) = start(:)
5687  tmpstart(1) = 1
5688  tmpedge(1) = edge(1) - dateline
5689  allocate(tmpout(tmpedge(1), tmpedge(2), tmpedge(3), tmpedge(4)), stat=status)
5690  if (status /= 0) then
5691  print *, "ERROR: Unable to allocate tmpedge: ", status
5692  return
5693  end if
5694  status = nf90_get_var(grp_id, dset_id, tmpout, start=tmpstart, &
5695  stride=stride, count=tmpedge)
5696  if (status /= nf90_noerr) then
5697  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5698  return
5699  end if
5700  outref(dateline+1:edge(1),:,:,:) = tmpout(:,:,:,:)
5701 
5702  deallocate(tmpout, stat=status)
5703  if (status /= 0) then
5704  print *, "Failed to deallocate tmpout: ", status
5705  return
5706  end if
5707 
5708  end if
5709  status = 0
5710  return
5711 
5712  end function readler5
5713 
5714  ! Read in 2.2 um surface database
5715  integer function readswir2(start, edge, stride, sds_name, grp_id, outref) RESULT(status)
5716 
5717 ! include 'hdf.f90'
5718 ! include 'dffunc.f90'
5719  use netcdf
5720 
5721  implicit none
5722 
5723  integer, dimension(3), intent(in) :: start, edge, stride
5724  integer, intent(in) :: grp_id
5725  real, intent(out) :: outref(edge(1),edge(2))
5726 
5727  ! HDF vars
5728  character(len=255) :: sds_name
5729  character(len=255) :: dset_name
5730  character(len=255) :: attr_name
5731  character(len=255) :: group_name
5732 
5733  integer :: nc_id
5734  integer :: dim_id
5735  integer :: dset_id
5736  integer :: sds_index, sds_id
5737  integer, dimension(3) :: tmpedge, tmpstart
5738  real, dimension(:,:), allocatable :: tmpout
5739 
5740  dset_name = sds_name
5741  status = nf90_inq_varid(grp_id, dset_name, dset_id)
5742  if (status /= nf90_noerr) then
5743  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
5744  return
5745  end if
5746 
5747  if (dateline6 .eq. 0) then
5748  status = nf90_get_var(grp_id, dset_id, outref, start=start, &
5749  stride=stride, count=edge)
5750  if (status /= nf90_noerr) then
5751  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5752  return
5753  end if
5754  else
5755  ! The granule straddles the dateline6, so we need to make an accommodation
5756  tmpedge(:) = edge(:)
5757  tmpedge(1) = dateline6
5758  allocate(tmpout(tmpedge(1), tmpedge(2)), stat=status)
5759  if (status /= 0) then
5760  print *, "ERROR: Unable to allocate tmpedge: ", status
5761  return
5762  end if
5763  status = nf90_get_var(grp_id, dset_id, tmpout, start=start, &
5764  stride=stride, count=tmpedge)
5765  if (status /= nf90_noerr) then
5766  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5767  return
5768  end if
5769  outref(1:dateline6, :) = tmpout
5770 
5771  deallocate(tmpout, stat=status)
5772  if (status /= 0) then
5773  print *, "Failed to deallocate tmpout: ", status
5774  return
5775  end if
5776 
5777  tmpstart(:) = start(:)
5778  tmpstart(1) = 1
5779  tmpedge(1) = edge(1) - dateline6
5780  allocate(tmpout(tmpedge(1), tmpedge(2)), stat=status)
5781  if (status /= 0) then
5782  print *, "ERROR: Unable to allocate tmpedge: ", status
5783  return
5784  end if
5785  status = nf90_get_var(grp_id, dset_id, tmpout, start=tmpstart, &
5786  stride=stride, count=tmpedge)
5787  if (status /= nf90_noerr) then
5788  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5789  return
5790  end if
5791  outref(dateline6+1:edge(1),:) = tmpout
5792 
5793  deallocate(tmpout, stat=status)
5794  if (status /= 0) then
5795  print *, "Failed to deallocate tmpout: ", status
5796  return
5797  end if
5798  end if
5799  return
5800 
5801  end function readswir2
5802 
5803  ! Read in 2.2 um surface database
5804  integer function readswir3(start3, edges3, stride3, sds_name, grp_id, outref) RESULT(status)
5805 
5806 ! include 'hdf.f90'
5807 ! include 'dffunc.f90'
5808  use netcdf
5809 
5810  implicit none
5811 
5812  integer, dimension(4), intent(in) :: start3, edges3, stride3
5813  integer, intent(in) :: grp_id
5814  real, dimension(:,:,:), intent(inout) :: outref
5815  ! HDF vars
5816  character(len=255) :: sds_name
5817  character(len=255) :: dset_name
5818  character(len=255) :: attr_name
5819  character(len=255) :: group_name
5820 
5821  integer :: nc_id
5822  integer :: dim_id
5823  integer :: dset_id
5824  integer :: sds_index, sds_id
5825  integer, dimension(4) :: tmpedge, tmpstart
5826  real, dimension(:,:,:), allocatable :: tmpout
5827  character(len=255) :: tmp_name
5828  integer :: rank, ntype, nattrs
5829  integer, dimension(4) :: dims
5830 
5831  status = -1
5832 
5833  dset_name = sds_name
5834  status = nf90_inq_varid(grp_id, dset_name, dset_id)
5835  if (status /= nf90_noerr) then
5836  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
5837  return
5838  end if
5839 
5840  if (dateline6 .eq. 0) then
5841  status = nf90_get_var(grp_id, dset_id, outref, start=start3, &
5842  stride=stride3, count=edges3)
5843  if (status /= nf90_noerr) then
5844  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5845  return
5846  end if
5847  else
5848  ! The granule straddles the dateline6, so we need to make an accommodation
5849  tmpedge(:) = edges3(:)
5850  tmpedge(1) = dateline6
5851  allocate(tmpout(tmpedge(1), tmpedge(2), tmpedge(3)), stat=status)
5852  if (status /= 0) then
5853  print *, "ERROR: Unable to allocate tmpedge: ", status
5854  return
5855  end if
5856  status = nf90_get_var(grp_id, dset_id, tmpout, start=start3, &
5857  stride=stride3, count=tmpedge)
5858  if (status /= nf90_noerr) then
5859  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5860  return
5861  end if
5862  outref(1:dateline6, :, :) = tmpout
5863 
5864  deallocate(tmpout, stat=status)
5865  if (status /= 0) then
5866  print *, "Failed to deallocate tmpout: ", status
5867  return
5868  end if
5869 
5870  tmpstart(:) = start3(:)
5871  tmpstart(1) = 1
5872  tmpedge(1) = edges3(1) - dateline6
5873  allocate(tmpout(tmpedge(1), tmpedge(2), tmpedge(3)), stat=status)
5874  if (status /= 0) then
5875  print *, "ERROR: Unable to allocate tmpedge: ", status
5876  return
5877  end if
5878  status = nf90_get_var(grp_id, dset_id, tmpout, start=tmpstart, &
5879  stride=stride3, count=tmpedge)
5880  if (status /= nf90_noerr) then
5881  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5882  return
5883  end if
5884  outref(dateline6+1:edges3(1),:,:) = tmpout
5885 
5886  deallocate(tmpout, stat=status)
5887  if (status /= 0) then
5888  print *, "Failed to deallocate tmpout: ", status
5889  return
5890  end if
5891  end if
5892  return
5893 
5894  dset_name = sds_name
5895  status = nf90_inq_varid(grp_id, dset_name, dset_id)
5896  if (status /= nf90_noerr) then
5897  print *, "ERROR: Failed to get ID of dataset "//trim(dset_name)//": ", status
5898  return
5899  end if
5900 
5901  if (dateline6 .eq. 0) then
5902  status = nf90_get_var(grp_id, dset_id, tmpout, start=start3, &
5903  stride=stride3, count=edges3)
5904  if (status /= nf90_noerr) then
5905  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5906  return
5907  end if
5908  else
5909  ! The granule straddles the dateline6, so we need to make an accommodation
5910  tmpedge(:) = edges3(:)
5911  tmpedge(1) = dateline6
5912  allocate(tmpout(tmpedge(1), tmpedge(2), tmpedge(3)), stat=status)
5913  if (status /= 0) then
5914  print *, "ERROR: Unable to allocate tmpedge: ", status
5915  return
5916  end if
5917  status = nf90_get_var(grp_id, dset_id, tmpout, start=start3, &
5918  stride=stride3, count=tmpedge)
5919  if (status /= nf90_noerr) then
5920  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5921  return
5922  end if
5923  outref(1:dateline6, :, :) = tmpout
5924 
5925  deallocate(tmpout, stat=status)
5926  if (status /= 0) then
5927  print *, "Failed to deallocate tmpout: ", status
5928  return
5929  end if
5930 
5931  tmpstart(:) = start3(:)
5932  tmpstart(1) = 0
5933  tmpedge(1) = edges3(1) - dateline6
5934  allocate(tmpout(tmpedge(1), tmpedge(2), tmpedge(3)), stat=status)
5935  if (status /= 0) then
5936  print *, "ERROR: Unable to allocate tmpedge: ", status
5937  return
5938  end if
5939  status = nf90_get_var(grp_id, dset_id, tmpout, start=tmpstart, &
5940  stride=stride3, count=tmpedge)
5941  if (status /= nf90_noerr) then
5942  print *, "ERROR: Failed to read dataset "//trim(dset_name)//": ", status
5943  return
5944  end if
5945  outref(dateline6+1:edges3(1),:,:) = tmpout
5946 
5947  deallocate(tmpout, stat=status)
5948  if (status /= 0) then
5949  print *, "Failed to deallocate tmpout: ", status
5950  return
5951  end if
5952  end if
5953  return
5954  end function readswir3
5955 
5956  integer function latlon_to_index_ler(lat, lon, ilat, ilon) result(status)
5957  implicit none
5958 
5959  real, intent(in) :: lat
5960  real, intent(in) :: lon
5961  integer, intent(inout) :: ilat
5962  integer, intent(inout) :: ilon
5963 
5964  status = 0
5965  if (lat > 90.0 .OR. lat < -90.0) then
5966  print *, "ERROR: Invalid latitude specified: ", lat
5967  status = -1
5968  return
5969  end if
5970  if (lon > 180.0 .OR. lon < -180.0) then
5971  print *, "ERROR: Invalid longitude specified: ", lon
5972  status = -1
5973  return
5974  end if
5975 
5976  ilat = (lat + 90.0) * 10.0 + 1
5977  if (ilat > 1800) ilat = 1800
5978  if (ilat < 1) ilat = 1
5979 
5980  ilon = (lon + 180.0) * 10.0 + 1
5981  if (ilon > 3600) ilon = 3600
5982  if (ilon < 1) ilon = 1
5983 
5984  return
5985 
5986  end function latlon_to_index_ler
5987 
5988  real function get_viirs_ler412(latidx, lonidx) result(ref)
5989  implicit none
5990 
5991  integer, intent(in) :: latidx
5992  integer, intent(out) :: lonidx
5993 
5994  integer :: i, j
5995 
5996  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
5997  i = lonidx - lerstart(1)
5998  else
5999  i = lonidx + dateline
6000  end if
6001  j = latidx - lerstart(2)
6002 
6003  ref = vgref412_all(i,j)
6004  return
6005 
6006  end function get_viirs_ler412
6007 
6008  real function get_viirs_ler488(latidx, lonidx) result(ref)
6009  implicit none
6010 
6011  integer, intent(in) :: latidx
6012  integer, intent(out) :: lonidx
6013 
6014  integer :: i, j
6015 
6016  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
6017  i = lonidx - lerstart(1)
6018  else
6019  i = lonidx + dateline
6020  end if
6021  j = latidx - lerstart(2)
6022 
6023  ref = vgref488_all(i,j)
6024  return
6025 
6026  end function get_viirs_ler488
6027 
6028  real function get_viirs_ler670(latidx, lonidx) result(ref)
6029  implicit none
6030 
6031  integer, intent(in) :: latidx
6032  integer, intent(out) :: lonidx
6033 
6034  integer :: i, j
6035 
6036  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
6037  i = lonidx - lerstart(1)
6038  else
6039  i = lonidx + dateline
6040  end if
6041  j = latidx - lerstart(2)
6042 
6043  ref = vgref670_all(i,j)
6044  return
6045 
6046  end function get_viirs_ler670
6047 
6048  real function get_modis_ler412(latidx, lonidx) result(ref)
6049  implicit none
6050 
6051  integer, intent(in) :: latidx
6052  integer, intent(out) :: lonidx
6053 
6054  integer :: i, j
6055 
6056  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
6057  i = lonidx - lerstart(1)
6058  else
6059  i = lonidx + dateline
6060  end if
6061  j = latidx - lerstart(2)
6062 
6063  ref = gref412_all(i,j)
6064  return
6065 
6066  end function get_modis_ler412
6067 
6068  real function get_modis_ler470(latidx, lonidx) result(ref)
6069  implicit none
6070 
6071  integer, intent(in) :: latidx
6072  integer, intent(out) :: lonidx
6073 
6074  integer :: i, j
6075 
6076  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
6077  i = lonidx - lerstart(1)
6078  else
6079  i = lonidx + dateline
6080  end if
6081  j = latidx - lerstart(2)
6082 
6083  ref = gref470_all(i,j)
6084  return
6085 
6086  end function get_modis_ler470
6087 
6088  real function get_modis_ler650(latidx, lonidx) result(ref)
6089  implicit none
6090 
6091  integer, intent(in) :: latidx
6092  integer, intent(out) :: lonidx
6093 
6094  integer :: i, j
6095 
6096  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
6097  i = lonidx - lerstart(1)
6098  else
6099  i = lonidx + dateline
6100  end if
6101  j = latidx - lerstart(2)
6102 
6103  ref = gref650_all(i,j)
6104  return
6105 
6106  end function get_modis_ler650
6107 
6108  real function get_modis_ler865(latidx, lonidx) result(ref)
6109  implicit none
6110 
6111  integer, intent(in) :: latidx
6112  integer, intent(out) :: lonidx
6113 
6114  integer :: i, j
6115 
6116  if (dateline .eq. 0 .OR. lonidx .gt. lerstart(1)) then
6117  i = lonidx - lerstart(1)
6118  else
6119  i = lonidx + dateline
6120  end if
6121  j = latidx - lerstart(2)
6122 
6123  ref = gref865_all(i,j)
6124  return
6125 
6126  end function get_modis_ler865
6127 
6128  real function get_viirs_modisbrdf_ler412(ilat, ilon, ndvi, sa, ra) result(ref)
6129  implicit none
6130 
6131  integer, intent(in) :: ilat
6132  integer, intent(out) :: ilon
6133  real, intent(in) :: ndvi
6134  real, intent(in) :: sa
6135  real, intent(in) :: ra
6136 
6137  real :: mb_sr412
6138  real :: m_sr412
6139  real :: v_sr412
6140 
6141  ref = -999.0
6142 
6143  mb_sr412 = get_ler412(ilat, ilon, ndvi, sa, ra)
6144  if (mb_sr412 < -900.0) then
6145 ! print *, "ERROR: Undefined MODIS BRDF-corrected surface reflectance found: ", mb_sr412
6146  return
6147  end if
6148 
6149  m_sr412 = get_modis_ler412(ilat,ilon)
6150  if (m_sr412 < -900.0) then
6151 ! print *, "ERROR: Undefined MODIS all-angle surface reflectance found: ", m_sr412
6152  return
6153  end if
6154 
6155  v_sr412 = get_viirs_ler412(ilat,ilon)
6156  if (v_sr412 < -900.0) then
6157 ! print *, "ERROR: Undefined VIIRS all-angle surface reflectance found: ", v_sr412
6158  return
6159  end if
6160 
6161  ref = v_sr412 * (mb_sr412 / m_sr412)
6162  return
6163 
6164  end function get_viirs_modisbrdf_ler412
6165 
6166  real function get_viirs_modisbrdf_ler488(ilat, ilon, ndvi, sa, ra) result(ref)
6167  implicit none
6168 
6169  integer, intent(in) :: ilat
6170  integer, intent(out) :: ilon
6171  real, intent(in) :: ndvi
6172  real, intent(in) :: sa
6173  real, intent(in) :: ra
6174 
6175  real :: mb_sr470
6176  real :: m_sr470
6177  real :: v_sr488
6178 
6179  ref = -999.0
6180 
6181  mb_sr470 = get_ler470(ilat, ilon, ndvi, sa, ra)
6182  if (mb_sr470 < -900.0) then
6183 ! print *, "ERROR: Undefined MODIS BRDF-corrected surface reflectance found: ", mb_sr470
6184  return
6185  end if
6186 
6187  m_sr470 = get_modis_ler470(ilat,ilon)
6188  if (m_sr470 < -900.0) then
6189 ! print *, "ERROR: Undefined MODIS all-angle surface reflectance found: ", m_sr470
6190  return
6191  end if
6192 
6193  v_sr488 = get_viirs_ler488(ilat,ilon)
6194  if (v_sr488 < -900.0) then
6195 ! print *, "ERROR: Undefined VIIRS all-angle surface reflectance found: ", v_sr488
6196  return
6197  end if
6198 
6199  ref = v_sr488 * (mb_sr470 / m_sr470)
6200 
6201  return
6202 
6203  end function get_viirs_modisbrdf_ler488
6204 
6205  real function get_viirs_modisbrdf_ler670(ilat, ilon, ndvi, sa, ra) result(ref)
6206  implicit none
6207 
6208  integer, intent(in) :: ilat
6209  integer, intent(out) :: ilon
6210  real, intent(in) :: ndvi
6211  real, intent(in) :: sa
6212  real, intent(in) :: ra
6213 
6214  real :: mb_sr650
6215  real :: m_sr650
6216  real :: v_sr670
6217 
6218  ref = -999.0
6219 
6220  mb_sr650 = get_ler650(ilat, ilon, ndvi, sa, ra)
6221  if (mb_sr650 < -900.0) then
6222 ! print *, "ERROR: Undefined MODIS BRDF-corrected surface reflectance found: ", mb_sr650
6223  return
6224  end if
6225 
6226  m_sr650 = get_modis_ler650(ilat,ilon)
6227  if (m_sr650 < -900.0) then
6228 ! print *, "ERROR: Undefined MODIS all-angle surface reflectance found: ", m_sr650
6229  return
6230  end if
6231 
6232  v_sr670 = get_viirs_ler670(ilat,ilon)
6233  if (v_sr670 < -900.0) then
6234 ! print *, "ERROR: Undefined VIIRS all-angle surface reflectance found: ", v_sr670
6235  return
6236  end if
6237 
6238  ref = v_sr670 * (mb_sr650 / m_sr650)
6239 
6240  return
6241 
6242  end function get_viirs_modisbrdf_ler670
6243 
6244 
6245  integer function get_geographic_zone(lat, lon, status) result(zone)
6246  implicit none
6247 
6248  real, intent(in) :: lat
6249  real, intent(in) :: lon
6250 
6251  integer :: ilat, ilon
6252  integer :: status
6253 
6254  status = -1
6255 
6256  if (lat > 90.0 .OR. lat < -90.0) then
6257  print *, "ERROR: Invalid latitude specified: ", lat
6258  status = -1
6259  return
6260  end if
6261  if (lon > 180.0 .OR. lon < -180.0) then
6262  print *, "ERROR: Invalid longitude specified: ", lon
6263  status = -1
6264  return
6265  end if
6266 
6267  ilat = (lat + 90.0) * 10 + 1
6268  if (ilat > 1800) ilat = 1800
6269  if (ilat < 1) ilat = 1
6270 
6271  ilon = (lon + 180.0) * 10 + 1
6272  if (ilon > 3600) ilon = 3600
6273  if (ilon < 1) ilon = 1
6274 
6275  zone = terrain_flag_new(ilon,ilat)
6276  status = 0
6277 
6278  return
6279 
6280  end function get_geographic_zone
6281 
6282 
6283  integer function get_sfc_elev_std(lat, lon, status) result(elev_std)
6284  implicit none
6285 
6286  real, intent(in) :: lat
6287  real, intent(in) :: lon
6288 
6289  integer :: ilat, ilon
6290  integer :: status
6291 
6292  status = -1
6293 
6294  if (lat > 90.0 .OR. lat < -90.0) then
6295  print *, "ERROR: Invalid latitude specified: ", lat
6296  status = -1
6297  return
6298  end if
6299  if (lon > 180.0 .OR. lon < -180.0) then
6300  print *, "ERROR: Invalid longitude specified: ", lon
6301  status = -1
6302  return
6303  end if
6304 
6305  ilat = (lat + 90.0) * 10 + 1
6306  if (ilat > 1800) ilat = 1800
6307  if (ilat < 1) ilat = 1
6308 
6309  ilon = (lon + 180.0) * 10 + 1
6310  if (ilon > 3600) ilon = 3600
6311  if (ilon < 1) ilon = 1
6312 
6313  elev_std = sfc_elev_std(ilon,ilat)
6314  status = 0
6315 
6316  return
6317 
6318  end function get_sfc_elev_std
6319 
6320  real function get_background_aod(lat, lon, season, status) result(aod)
6321  implicit none
6322 
6323  real, intent(in) :: lat
6324  real, intent(in) :: lon
6325  integer, intent(in) :: season
6326 
6327  integer :: ilat, ilon
6328  integer :: status
6329 
6330  status = -1
6331 
6332  if (lat > 90.0 .OR. lat < -90.0) then
6333  print *, "ERROR: Invalid latitude specified: ", lat
6334  status = -1
6335  return
6336  end if
6337  if (lon > 180.0 .OR. lon < -180.0) then
6338  print *, "ERROR: Invalid longitude specified: ", lon
6339  status = -1
6340  return
6341  end if
6342 
6343  ilat = floor(lat + 90.0) + 1
6344  if (ilat > 180) ilat = 180
6345  if (ilat < 1) ilat = 1
6346 
6347  ilon = floor(lon + 180.0) + 1
6348  if (ilon > 360) ilon = 360
6349  if (ilon < 1) ilon = 1
6350 
6351  aod = bg_aod(ilon,ilat)
6352  status = 0
6353 
6354  return
6355 
6356  end function get_background_aod
6357 end module modis_surface
modis_surface::get_viirs_modisbrdf_ler412
real function, public get_viirs_modisbrdf_ler412(ilat, ilon, ndvi, sa, ra)
Definition: modis_surface_nc4.f95:6129
modis_surface::get_modis_ler650
real function, public get_modis_ler650(latidx, lonidx)
Definition: modis_surface_nc4.f95:6089
modis_surface::get_viirs_modisbrdf_ler670
real function, public get_viirs_modisbrdf_ler670(ilat, ilon, ndvi, sa, ra)
Definition: modis_surface_nc4.f95:6206
modis_surface::get_viirs_ler670
real function, public get_viirs_ler670(latidx, lonidx)
Definition: modis_surface_nc4.f95:6029
modis_surface::readswir2
integer function readswir2(start, edge, stride, sds_name, grp_id, outref)
Definition: modis_surface_nc4.f95:5716
modis_surface::get_viirs_modisbrdf_ler488
real function, public get_viirs_modisbrdf_ler488(ilat, ilon, ndvi, sa, ra)
Definition: modis_surface_nc4.f95:6167
modis_surface::get_swir_range
real function, dimension(2), public get_swir_range(latidx, lonidx)
Definition: modis_surface_nc4.f95:5251
modis_surface::get_swir_coeffs470
real function, dimension(3), public get_swir_coeffs470(latidx, lonidx)
Definition: modis_surface_nc4.f95:5202
modis_surface::get_ler470
real function, public get_ler470(latidx, lonidx, NDVI, scatAngle, relaz)
Definition: modis_surface_nc4.f95:5367
modis_surface::readswir3
integer function readswir3(start3, edges3, stride3, sds_name, grp_id, outref)
Definition: modis_surface_nc4.f95:5805
modis_surface::get_modis_ler412
real function, public get_modis_ler412(latidx, lonidx)
Definition: modis_surface_nc4.f95:6049
modis_surface::load_brdf
integer function, public load_brdf(brdffile)
Definition: modis_surface_nc4.f95:283
modis_surface::latlon_to_index_ler
integer function, public latlon_to_index_ler(lat, lon, ilat, ilon)
Definition: modis_surface_nc4.f95:5957
modis_surface::get_background_aod
real function, public get_background_aod(lat, lon, season, status)
Definition: modis_surface_nc4.f95:6321
modis_surface::set_limits6
integer function, public set_limits6(locedge, lat, long)
Definition: modis_surface_nc4.f95:4803
modis_surface::get_ler865
real function, public get_ler865(latidx, lonidx)
Definition: modis_surface_nc4.f95:5268
modis_surface::get_geographic_zone
integer function, public get_geographic_zone(lat, lon, status)
Definition: modis_surface_nc4.f95:6246
modis_surface::sfc_elev_std
real, dimension(3600, 1800), public sfc_elev_std
Definition: modis_surface_nc4.f95:52
modis_surface::get_swir_stderr470
real function, public get_swir_stderr470(latidx, lonidx)
Definition: modis_surface_nc4.f95:5235
modis_surface::get_viirs_ler488
real function, public get_viirs_ler488(latidx, lonidx)
Definition: modis_surface_nc4.f95:6009
modis_surface::set_limits
integer function, public set_limits(locedge, lat, long)
Definition: modis_surface_nc4.f95:4640
modis_surface::get_modis_ler470
real function, public get_modis_ler470(latidx, lonidx)
Definition: modis_surface_nc4.f95:6069
trim
string & trim(string &s, const string &delimiters)
Definition: EnvsatUtil.cpp:29
modis_surface
Definition: modis_surface_nc4.f95:1
sortrx
subroutine sortrx(N, DATA, INDEX)
Definition: sortrx.f:8
modis_surface::get_ler412
real function, public get_ler412(latidx, lonidx, NDVI, scatAngle, relaz)
Definition: modis_surface_nc4.f95:5286
modis_surface::load_seasonal_desert
integer function, public load_seasonal_desert(file)
Definition: modis_surface_nc4.f95:213
modis_surface::get_brdfcorr_sr
integer function, public get_brdfcorr_sr(lat, lon, ra, sa, vza, amf, elev, month, ndvi, stdv, gzone, lc_type, bgaod, sr412, sr470, sr650, use_alternate_brdf, debug)
Definition: modis_surface_nc4.f95:749
modis_surface::get_viirs_ler412
real function, public get_viirs_ler412(latidx, lonidx)
Definition: modis_surface_nc4.f95:5989
modis_surface::unload_brdf
subroutine, public unload_brdf(status)
Definition: modis_surface_nc4.f95:721
modis_surface::get_aot500
real function, public get_aot500(lat, lon, elev, sa, season, ndvi, gzone, lc_type, stdv02, aot412_91, aot412_93, aot412_94, aot412_96, aot412_995, aot470_91, aot470_92, aot470_93, aot470_94, aot470_95, aot470_96, aot470_995, aot412_91_dust, aot412_93_dust, aot412_94_dust, aot412_96_dust, aot412_995_dust, aot470_91_dust, aot470_92_dust, aot470_93_dust, aot470_94_dust, aot470_95_dust, aot470_96_dust, aot470_995_dust, ae, status, debug)
Definition: modis_surface_nc4.f95:3261
modis_surface::get_ler650
real function, public get_ler650(latidx, lonidx, NDVI, scatAngle, relaz)
Definition: modis_surface_nc4.f95:5451
modis_surface::terrain_flag_new
integer, dimension(3600, 1800), public terrain_flag_new
Definition: modis_surface_nc4.f95:51
modis_surface::terrain_flag
real, dimension(3600, 1800), public terrain_flag
Definition: modis_surface_nc4.f95:52
modis_surface::get_swir_stderr412
real function, public get_swir_stderr412(latidx, lonidx)
Definition: modis_surface_nc4.f95:5219
modis_surface::get_sfc_elev_std
integer function, public get_sfc_elev_std(lat, lon, status)
Definition: modis_surface_nc4.f95:6284
modis_surface::load_swir_coeffs
integer function, public load_swir_coeffs(file, season)
Definition: modis_surface_nc4.f95:5094
modis_surface::load_hdfler
integer function, public load_hdfler(lut_file, season)
Definition: modis_surface_nc4.f95:4890
modis_surface::load_terrainflg_tables
integer function, public load_terrainflg_tables(tflg_file, season)
Definition: modis_surface_nc4.f95:82
modis_surface::get_swir_coeffs412
real function, dimension(3), public get_swir_coeffs412(latidx, lonidx)
Definition: modis_surface_nc4.f95:5185
modis_surface::get_modis_ler865
real function, public get_modis_ler865(latidx, lonidx)
Definition: modis_surface_nc4.f95:6109


ABOUT

Our Team

Contact Us

DATA

Get Started

Find Data

Use Data

TOOLS

SeaBASS

SeaDAS

Giovanni Data Visualizer

Worldview Mapping Interface

Mission Quality Monitor

HELP

Level 1 & 2 Browser Help

Level 3 & 4 Browser Help

File Search Help

Search & Download Help

Earthdata Forum

Join Mailing List

How to Cite Data

CONNECT WITH US
COMPLIANCE

Web Privacy Policy

Data & Information Policy

Communications Policy

Accessibility Policy

Freedom of Information Act

USA.gov

Responsible NASA Official: Sean Bailey
Curator: OceanColor Webmaster