PageRenderTime 50ms CodeModel.GetById 12ms RepoModel.GetById 0ms app.codeStats 0ms

/WPS/geogrid/src/interp_module.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1189 lines | 875 code | 146 blank | 168 comment | 398 complexity | 709ca1e3812eec0ceef1b2b48c58ea4d MD5 | raw file
Possible License(s): AGPL-1.0

Large files files are truncated, but you can click here to view the full file

  1. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  2. ! MODULE INTERP_MODULE
  3. !
  4. ! This module provides routines for interpolation.
  5. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  6. module interp_module
  7. use bitarray_module
  8. use misc_definitions_module
  9. use module_debug
  10. use queue_module
  11. contains
  12. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  13. ! Name: interp_array_from_string
  14. !
  15. ! Purpose:
  16. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  17. function interp_array_from_string(interp_string)
  18. implicit none
  19. ! Arguments
  20. character (len=*), intent(in) :: interp_string
  21. ! Local variables
  22. integer :: j, p1, p2, iend, num_methods
  23. ! Return value
  24. integer, pointer, dimension(:) :: interp_array_from_string
  25. ! Get an idea of how many interpolation methods are in the string
  26. ! so we can allocate an appropriately sized array
  27. num_methods = 1
  28. do j=1,len_trim(interp_string)
  29. if (interp_string(j:j) == '+') num_methods = num_methods + 1
  30. end do
  31. allocate(interp_array_from_string(num_methods+1))
  32. interp_array_from_string = 0
  33. iend = len_trim(interp_string)
  34. p1 = 1
  35. p2 = index(interp_string(1:iend),'+')
  36. j = 1
  37. do while(p2 >= p1)
  38. if (index(interp_string(p1:p2-1),'nearest_neighbor') /= 0 .and. &
  39. len_trim(interp_string(p1:p2-1)) == len_trim('nearest_neighbor')) then
  40. interp_array_from_string(j) = N_NEIGHBOR
  41. j = j + 1
  42. else if (index(interp_string(p1:p2-1),'average_4pt') /= 0 .and. &
  43. len_trim(interp_string(p1:p2-1)) == len_trim('average_4pt')) then
  44. interp_array_from_string(j) = AVERAGE4
  45. j = j + 1
  46. else if (index(interp_string(p1:p2-1),'average_16pt') /= 0 .and. &
  47. len_trim(interp_string(p1:p2-1)) == len_trim('average_16pt')) then
  48. interp_array_from_string(j) = AVERAGE16
  49. j = j + 1
  50. else if (index(interp_string(p1:p2-1),'wt_average_4pt') /= 0 .and. &
  51. len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_4pt')) then
  52. interp_array_from_string(j) = W_AVERAGE4
  53. j = j + 1
  54. else if (index(interp_string(p1:p2-1),'wt_average_16pt') /= 0 .and. &
  55. len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_16pt')) then
  56. interp_array_from_string(j) = W_AVERAGE16
  57. j = j + 1
  58. else if (index(interp_string(p1:p2-1),'four_pt') /= 0 .and. &
  59. len_trim(interp_string(p1:p2-1)) == len_trim('four_pt')) then
  60. interp_array_from_string(j) = FOUR_POINT
  61. j = j + 1
  62. else if (index(interp_string(p1:p2-1),'sixteen_pt') /= 0 .and. &
  63. len_trim(interp_string(p1:p2-1)) == len_trim('sixteen_pt')) then
  64. interp_array_from_string(j) = SIXTEEN_POINT
  65. j = j + 1
  66. else if (index(interp_string(p1:p2-1),'search') /= 0 .and. &
  67. len_trim(interp_string(p1:p2-1)) == len_trim('search')) then
  68. interp_array_from_string(j) = SEARCH
  69. j = j + 1
  70. else
  71. if (index(interp_string(p1:p2-1),'average_gcell') == 0) &
  72. call mprintf(.true.,WARN,'Unrecognized interpolation method %s.',s1=interp_string(p1:p2-1))
  73. end if
  74. p1 = p2 + 1
  75. p2 = index(interp_string(p1:iend),'+') + p1 - 1
  76. end do
  77. p2 = iend+1
  78. if (p1 < iend) then
  79. if (index(interp_string(p1:p2-1),'nearest_neighbor') /= 0 .and. &
  80. len_trim(interp_string(p1:p2-1)) == len_trim('nearest_neighbor')) then
  81. interp_array_from_string(j) = N_NEIGHBOR
  82. j = j + 1
  83. else if (index(interp_string(p1:p2-1),'average_4pt') /= 0 .and. &
  84. len_trim(interp_string(p1:p2-1)) == len_trim('average_4pt')) then
  85. interp_array_from_string(j) = AVERAGE4
  86. j = j + 1
  87. else if (index(interp_string(p1:p2-1),'average_16pt') /= 0 .and. &
  88. len_trim(interp_string(p1:p2-1)) == len_trim('average_16pt')) then
  89. interp_array_from_string(j) = AVERAGE16
  90. j = j + 1
  91. else if (index(interp_string(p1:p2-1),'wt_average_4pt') /= 0 .and. &
  92. len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_4pt')) then
  93. interp_array_from_string(j) = W_AVERAGE4
  94. j = j + 1
  95. else if (index(interp_string(p1:p2-1),'wt_average_16pt') /= 0 .and. &
  96. len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_16pt')) then
  97. interp_array_from_string(j) = W_AVERAGE16
  98. j = j + 1
  99. else if (index(interp_string(p1:p2-1),'four_pt') /= 0 .and. &
  100. len_trim(interp_string(p1:p2-1)) == len_trim('four_pt')) then
  101. interp_array_from_string(j) = FOUR_POINT
  102. j = j + 1
  103. else if (index(interp_string(p1:p2-1),'sixteen_pt') /= 0 .and. &
  104. len_trim(interp_string(p1:p2-1)) == len_trim('sixteen_pt')) then
  105. interp_array_from_string(j) = SIXTEEN_POINT
  106. j = j + 1
  107. else if (index(interp_string(p1:p2-1),'search') /= 0 .and. &
  108. len_trim(interp_string(p1:p2-1)) == len_trim('search')) then
  109. interp_array_from_string(j) = SEARCH
  110. j = j + 1
  111. else
  112. if (index(interp_string(p1:p2-1),'average_gcell') == 0) &
  113. call mprintf(.true.,WARN,'Unrecognized interpolation method %s.',s1=interp_string(p1:p2-1))
  114. end if
  115. end if
  116. return
  117. end function interp_array_from_string
  118. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  119. ! Name: interp_sequence
  120. !
  121. ! Purpose: Delegates the actual task of interpolation to specific
  122. ! interpolation routines defined in the module.
  123. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  124. recursive function interp_sequence(xx, yy, izz, array, start_x, end_x, &
  125. start_y, end_y, start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  126. implicit none
  127. ! Arguments
  128. integer, intent(in) :: start_x, start_y, start_z
  129. integer, intent(in) :: end_x, end_y, end_z
  130. integer, intent(in) :: izz ! The z-index of the 2d-array to
  131. ! interpolate within
  132. real, intent(in) :: xx , yy ! The location to interpolate to
  133. real, intent(in) :: msgval
  134. real, intent(in), optional :: maskval
  135. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(in) :: array
  136. integer, intent(in) :: idx
  137. integer, dimension(:), intent(in) :: interp_list
  138. real, dimension(start_x:end_x, start_y:end_y), intent(in), optional :: mask_array
  139. character (len=1), intent(in), optional :: mask_relational
  140. ! Return value
  141. real :: interp_sequence
  142. ! No more interpolation methods to try
  143. if (interp_list(idx) == 0) then
  144. interp_sequence = msgval
  145. return
  146. end if
  147. if (interp_list(idx) == FOUR_POINT) then
  148. interp_sequence = four_pt(xx, yy, izz, array, start_x, end_x, &
  149. start_y, end_y, start_z, end_z, &
  150. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  151. else if (interp_list(idx) == AVERAGE4) then
  152. interp_sequence = four_pt_average(xx, yy, izz, array, start_x, end_x, &
  153. start_y, end_y, start_z, end_z, &
  154. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  155. else if (interp_list(idx) == W_AVERAGE4) then
  156. interp_sequence = wt_four_pt_average(xx, yy, izz, array, start_x, end_x, &
  157. start_y, end_y, start_z, end_z, &
  158. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  159. else if (interp_list(idx) == N_NEIGHBOR) then
  160. interp_sequence = nearest_neighbor(xx, yy, izz, array, start_x, end_x, &
  161. start_y, end_y, start_z, end_z, &
  162. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  163. else if (interp_list(idx) == SIXTEEN_POINT) then
  164. interp_sequence = sixteen_pt(xx, yy, izz, array, start_x, end_x, &
  165. start_y, end_y, start_z, end_z, &
  166. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  167. else if (interp_list(idx) == SEARCH) then
  168. interp_sequence = search_extrap(xx, yy, izz, array, start_x, end_x, &
  169. start_y, end_y, start_z, end_z, &
  170. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  171. else if (interp_list(idx) == AVERAGE16) then
  172. interp_sequence = sixteen_pt_average(xx, yy, izz, array, start_x, end_x, &
  173. start_y, end_y, start_z, end_z, &
  174. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  175. else if (interp_list(idx) == W_AVERAGE16) then
  176. interp_sequence = wt_sixteen_pt_average(xx, yy, izz, array, start_x, end_x, &
  177. start_y, end_y, start_z, end_z, &
  178. msgval, interp_list, idx+1, mask_relational, maskval, mask_array)
  179. end if
  180. end function interp_sequence
  181. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  182. ! Name: nearest_neighbor
  183. !
  184. ! Purpose: Returns the point nearest to (xx,yy). If (xx,yy) is outside of the
  185. ! array, the point on the edge of the array nearest to (xx,yy) is returned.
  186. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  187. recursive function nearest_neighbor(xx, yy, izz, array, start_x, end_x, &
  188. start_y, end_y, start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  189. implicit none
  190. ! Arguments
  191. integer, intent(in) :: start_x, start_y, start_z
  192. integer, intent(in) :: end_x, end_y, end_z
  193. integer, intent(in) :: izz ! The z-index of the 2d-array to
  194. ! interpolate within
  195. real, intent(in) :: xx , yy ! The location to interpolate to
  196. real, intent(in) :: msgval
  197. real, intent(in), optional :: maskval
  198. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(in) :: array
  199. integer, dimension(:), intent(in) :: interp_list
  200. integer, intent(in) :: idx
  201. real, dimension(start_x:end_x, start_y:end_y), intent(in), optional :: mask_array
  202. character (len=1), intent(in), optional :: mask_relational
  203. ! Return value
  204. real :: nearest_neighbor
  205. ! Local variables
  206. integer :: ix, iy
  207. ix = nint(xx)
  208. iy = nint(yy)
  209. ! The first thing to do is to ensure that the point (xx,yy) is within the array
  210. if (ix < start_x .or. ix > end_x) then
  211. nearest_neighbor = msgval
  212. return
  213. end if
  214. if (iy < start_y .or. iy > end_y) then
  215. nearest_neighbor = msgval
  216. return
  217. end if
  218. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  219. if (mask_relational == '<' .and. mask_array(ix,iy) < maskval) then
  220. nearest_neighbor = msgval
  221. else if (mask_relational == '>' .and. mask_array(ix,iy) > maskval) then
  222. nearest_neighbor = msgval
  223. else if (mask_relational == ' ' .and. mask_array(ix,iy) == maskval) then
  224. nearest_neighbor = msgval
  225. else
  226. nearest_neighbor = array(ix,iy,izz)
  227. end if
  228. else if (present(mask_array) .and. present(maskval)) then
  229. if (maskval == mask_array(ix,iy)) then
  230. nearest_neighbor = msgval
  231. else
  232. nearest_neighbor = array(ix,iy,izz)
  233. end if
  234. else
  235. nearest_neighbor = array(ix,iy,izz)
  236. end if
  237. ! If we have a missing value, try the next interpolation method in the sequence
  238. if (nearest_neighbor == msgval) then
  239. nearest_neighbor = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  240. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  241. end if
  242. end function nearest_neighbor
  243. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  244. ! Name: search_extrap
  245. !
  246. ! Purpose: Returns the point nearest to (xx,yy) that has a non-missing value.
  247. ! If no valid value can be found in the array, msgval is returned.
  248. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  249. recursive function search_extrap(xx, yy, izz, array, start_x, end_x, &
  250. start_y, end_y, start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  251. implicit none
  252. ! Arguments
  253. integer, intent(in) :: start_x, start_y, start_z
  254. integer, intent(in) :: end_x, end_y, end_z
  255. integer, intent(in) :: izz ! The z-index of the 2d-array to search
  256. real, intent(in) :: xx , yy ! The location of the search origin
  257. real, intent(in) :: msgval
  258. real, intent(in), optional :: maskval
  259. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
  260. intent(in) :: array
  261. integer, dimension(:), intent(in) :: interp_list
  262. integer, intent(in) :: idx
  263. real, dimension(start_x:end_x, start_y:end_y), &
  264. intent(in), optional :: mask_array
  265. character (len=1), intent(in), optional :: mask_relational
  266. ! Return value
  267. real :: search_extrap
  268. ! Local variables
  269. integer :: i, j
  270. real :: distance
  271. logical :: found_valid
  272. type (bitarray) :: b
  273. type (queue) :: q
  274. type (q_data) :: qdata
  275. ! We only search if the starting point is within the array
  276. if (nint(xx) < start_x .or. nint(xx) > end_x .or. &
  277. nint(yy) < start_y .or. nint(yy) > end_y) then
  278. search_extrap = msgval
  279. return
  280. end if
  281. call bitarray_create(b, (end_x-start_x+1), (end_y-start_y+1))
  282. call q_init(q)
  283. found_valid = .false.
  284. qdata%x = nint(xx)
  285. qdata%y = nint(yy)
  286. call q_insert(q, qdata)
  287. call bitarray_set(b, qdata%x-start_x+1, qdata%y-start_y+1)
  288. do while (q_isdata(q) .and. (.not. found_valid))
  289. qdata = q_remove(q)
  290. i = qdata%x
  291. j = qdata%y
  292. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  293. if (mask_relational == '>' .and. mask_array(i,j) <= maskval .and. array(i,j,izz) /= msgval) then
  294. found_valid = .true.
  295. else if (mask_relational == '<' .and. mask_array(i,j) >= maskval .and. array(i,j,izz) /= msgval) then
  296. found_valid = .true.
  297. else if (mask_relational == ' ' .and. mask_array(i,j) /= maskval .and. array(i,j,izz) /= msgval) then
  298. found_valid = .true.
  299. end if
  300. else if (present(mask_array) .and. present(maskval)) then
  301. if (array(i,j,izz) /= msgval .and. mask_array(i,j) /= maskval) found_valid = .true.
  302. else
  303. if (array(i,j,izz) /= msgval) found_valid = .true.
  304. end if
  305. if (i-1 >= start_x) then
  306. if (.not. bitarray_test(b, (i-1)-start_x+1, j-start_y+1)) then
  307. qdata%x = i-1
  308. qdata%y = j
  309. call q_insert(q, qdata)
  310. call bitarray_set(b, (i-1)-start_x+1, j-start_y+1)
  311. end if
  312. end if
  313. if (i+1 <= end_x) then
  314. if (.not. bitarray_test(b, (i+1)-start_x+1, j-start_y+1)) then
  315. qdata%x = i+1
  316. qdata%y = j
  317. call q_insert(q, qdata)
  318. call bitarray_set(b, (i+1)-start_x+1, j-start_y+1)
  319. end if
  320. end if
  321. if (j-1 >= start_y) then
  322. if (.not. bitarray_test(b, i-start_x+1, (j-1)-start_y+1)) then
  323. qdata%x = i
  324. qdata%y = j-1
  325. call q_insert(q, qdata)
  326. call bitarray_set(b, i-start_x+1, (j-1)-start_y+1)
  327. end if
  328. end if
  329. if (j+1 <= end_y) then
  330. if (.not. bitarray_test(b, i-start_x+1, (j+1)-start_y+1)) then
  331. qdata%x = i
  332. qdata%y = j+1
  333. call q_insert(q, qdata)
  334. call bitarray_set(b, i-start_x+1, (j+1)-start_y+1)
  335. end if
  336. end if
  337. end do
  338. if (found_valid) then
  339. distance = (real(i)-xx)*(real(i)-xx)+(real(j)-yy)*(real(j)-yy)
  340. search_extrap = array(i,j,izz)
  341. do while (q_isdata(q))
  342. qdata = q_remove(q)
  343. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  344. if (mask_relational == '<' .and. mask_array(qdata%x,qdata%y) >= maskval &
  345. .and. array(qdata%x,qdata%y,izz) /= msgval) then
  346. if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then
  347. distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy)
  348. search_extrap = array(qdata%x, qdata%y, izz)
  349. end if
  350. else if (mask_relational == '>' .and. mask_array(qdata%x,qdata%y) <= maskval &
  351. .and. array(qdata%x,qdata%y,izz) /= msgval) then
  352. if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then
  353. distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy)
  354. search_extrap = array(qdata%x, qdata%y, izz)
  355. end if
  356. else if (mask_relational == ' ' .and. mask_array(qdata%x,qdata%y) /= maskval &
  357. .and. array(qdata%x,qdata%y,izz) /= msgval) then
  358. if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then
  359. distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy)
  360. search_extrap = array(qdata%x, qdata%y, izz)
  361. end if
  362. end if
  363. else if (present(mask_array) .and. present(maskval)) then
  364. if (array(qdata%x,qdata%y,izz) /= msgval .and. mask_array(qdata%x,qdata%y) /= maskval) then
  365. if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then
  366. distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy)
  367. search_extrap = array(qdata%x, qdata%y, izz)
  368. end if
  369. end if
  370. else
  371. if (array(qdata%x,qdata%y,izz) /= msgval) then
  372. if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then
  373. distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy)
  374. search_extrap = array(qdata%x, qdata%y, izz)
  375. end if
  376. end if
  377. end if
  378. end do
  379. else
  380. search_extrap = msgval
  381. end if
  382. call q_destroy(q)
  383. call bitarray_destroy(b)
  384. end function search_extrap
  385. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  386. ! Name: four_pt_average
  387. !
  388. ! Purpose: Average of four surrounding grid point values
  389. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  390. recursive function four_pt_average(xx, yy, izz, array, start_x, end_x, &
  391. start_y, end_y, start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  392. implicit none
  393. ! Arguments
  394. integer, intent(in) :: start_x, start_y, start_z
  395. integer, intent(in) :: end_x, end_y, end_z
  396. integer, intent(in) :: izz ! The z-index of the 2d-array to
  397. ! interpolate within
  398. real, intent(in) :: xx, yy ! The location to interpolate to
  399. real, intent(in) :: msgval
  400. real, intent(in), optional :: maskval
  401. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
  402. intent(in) :: array
  403. integer, dimension(:), intent(in) :: interp_list
  404. integer, intent(in) :: idx
  405. real, dimension(start_x:end_x, start_y:end_y), &
  406. intent(in), optional :: mask_array
  407. character (len=1), intent(in), optional :: mask_relational
  408. ! Return value
  409. real :: four_pt_average
  410. ! Local variables
  411. integer :: ifx, ify, icx, icy
  412. real :: fxfy, fxcy, cxfy, cxcy
  413. fxfy = 1.0
  414. fxcy = 1.0
  415. cxfy = 1.0
  416. cxcy = 1.0
  417. ifx = floor(xx)
  418. icx = ceiling(xx)
  419. ify = floor(yy)
  420. icy = ceiling(yy)
  421. ! First, make sure that the point is contained in the source array
  422. if (ifx < start_x .or. icx > end_x .or. &
  423. ify < start_y .or. icy > end_y) then
  424. ! But if the point is at most half a grid point out, we can
  425. ! still proceed with modified ifx, icx, ify, and icy.
  426. if (xx > real(start_x)-0.5 .and. ifx < start_x) then
  427. ifx = start_x
  428. icx = start_x
  429. else if (xx < real(end_x)+0.5 .and. icx > end_x) then
  430. ifx = end_x
  431. icx = end_x
  432. end if
  433. if (yy > real(start_y)-0.5 .and. ify < start_y) then
  434. ify = start_y
  435. icy = start_y
  436. else if (yy < real(end_y)+0.5 .and. icy > end_y) then
  437. ify = end_y
  438. icy = end_y
  439. end if
  440. if (ifx < start_x .or. icx > end_x .or. &
  441. ify < start_y .or. icy > end_y) then
  442. four_pt_average = msgval
  443. return
  444. end if
  445. end if
  446. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  447. ! we determine which maskval is useable by... if the symbol > is found, then only
  448. ! values less than 'maskval' can be used and if the symbol < is found,
  449. ! then only the values greater than 'maskval' can be used.
  450. if (mask_relational == '>') then
  451. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) > maskval) fxfy = 0.0
  452. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) > maskval) fxcy = 0.0
  453. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) > maskval) cxfy = 0.0
  454. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) > maskval) cxcy = 0.0
  455. else if (mask_relational == '<') then
  456. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) < maskval) fxfy = 0.0
  457. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) < maskval) fxcy = 0.0
  458. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) < maskval) cxfy = 0.0
  459. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) < maskval) cxcy = 0.0
  460. else !equal
  461. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0
  462. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0
  463. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0
  464. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0
  465. end if
  466. else if (present(mask_array) .and. present(maskval)) then
  467. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0
  468. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0
  469. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0
  470. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0
  471. else
  472. if (array(ifx, ify, izz) == msgval) fxfy = 0.0
  473. if (array(ifx, icy, izz) == msgval) fxcy = 0.0
  474. if (array(icx, ify, izz) == msgval) cxfy = 0.0
  475. if (array(icx, icy, izz) == msgval) cxcy = 0.0
  476. end if
  477. ! If all four points are missing, try the next interpolation method in the sequence
  478. if (fxfy == 0.0 .and. fxcy == 0.0 .and. cxfy == 0.0 .and. cxcy == 0.0) then
  479. four_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  480. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  481. else
  482. four_pt_average = (fxfy * array(ifx, ify, izz) + &
  483. fxcy * array(ifx, icy, izz) + &
  484. cxfy * array(icx, ify, izz) + &
  485. cxcy * array(icx, icy, izz) ) / (fxfy + fxcy + cxfy + cxcy)
  486. end if
  487. end function four_pt_average
  488. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  489. ! Name: wt_four_pt_average
  490. !
  491. ! Purpose: Weighted average of four surrounding grid point values
  492. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  493. recursive function wt_four_pt_average(xx, yy, izz, array, start_x, end_x, &
  494. start_y, end_y, start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  495. implicit none
  496. ! Arguments
  497. integer, intent(in) :: start_x, start_y, start_z
  498. integer, intent(in) :: end_x, end_y, end_z
  499. integer, intent(in) :: izz ! The z-index of the 2d-array to
  500. ! interpolate within
  501. real, intent(in) :: xx, yy ! The location to interpolate to
  502. real, intent(in) :: msgval
  503. real, intent(in), optional :: maskval
  504. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
  505. intent(in) :: array
  506. integer, dimension(:), intent(in) :: interp_list
  507. integer, intent(in) :: idx
  508. real, dimension(start_x:end_x, start_y:end_y), &
  509. intent(in), optional :: mask_array
  510. character (len=1), intent(in), optional :: mask_relational
  511. ! Return value
  512. real :: wt_four_pt_average
  513. ! Local variables
  514. integer :: ifx, ify, icx, icy
  515. real :: fxfy, fxcy, cxfy, cxcy
  516. ifx = floor(xx)
  517. icx = ceiling(xx)
  518. ify = floor(yy)
  519. icy = ceiling(yy)
  520. fxfy = max(0., 1.0 - sqrt((xx-real(ifx))**2+(yy-real(ify))**2))
  521. fxcy = max(0., 1.0 - sqrt((xx-real(ifx))**2+(yy-real(icy))**2))
  522. cxfy = max(0., 1.0 - sqrt((xx-real(icx))**2+(yy-real(ify))**2))
  523. cxcy = max(0., 1.0 - sqrt((xx-real(icx))**2+(yy-real(icy))**2))
  524. ! First, make sure that the point is contained in the source array
  525. if (ifx < start_x .or. icx > end_x .or. &
  526. ify < start_y .or. icy > end_y) then
  527. ! But if the point is at most half a grid point out, we can
  528. ! still proceed with modified ifx, icx, ify, and icy.
  529. if (xx > real(start_x)-0.5 .and. ifx < start_x) then
  530. ifx = start_x
  531. icx = start_x
  532. else if (xx < real(end_x)+0.5 .and. icx > end_x) then
  533. ifx = end_x
  534. icx = end_x
  535. end if
  536. if (yy > real(start_y)-0.5 .and. ifx < start_y) then
  537. ify = start_y
  538. icy = start_y
  539. else if (yy < real(end_y)+0.5 .and. icy > end_y) then
  540. ify = end_y
  541. icy = end_y
  542. end if
  543. if (ifx < start_x .or. icx > end_x .or. &
  544. ify < start_y .or. icy > end_y) then
  545. wt_four_pt_average = msgval
  546. return
  547. end if
  548. end if
  549. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  550. ! we determine which maskval is useable by... if the symbol > is found, then only
  551. ! values less than 'maskval' can be used and if the symbol < is found,
  552. ! then only the values greater than 'maskval' can be used.
  553. if (mask_relational == '>') then
  554. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) > maskval) fxfy = 0.0
  555. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) > maskval) fxcy = 0.0
  556. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) > maskval) cxfy = 0.0
  557. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) > maskval) cxcy = 0.0
  558. else if (mask_relational == '<') then
  559. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) < maskval) fxfy = 0.0
  560. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) < maskval) fxcy = 0.0
  561. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) < maskval) cxfy = 0.0
  562. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) < maskval) cxcy = 0.0
  563. else !equal
  564. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0
  565. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0
  566. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0
  567. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0
  568. end if
  569. else if (present(mask_array) .and. present(maskval)) then
  570. if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0
  571. if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0
  572. if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0
  573. if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0
  574. else
  575. if (array(ifx, ify, izz) == msgval) fxfy = 0.0
  576. if (array(ifx, icy, izz) == msgval) fxcy = 0.0
  577. if (array(icx, ify, izz) == msgval) cxfy = 0.0
  578. if (array(icx, icy, izz) == msgval) cxcy = 0.0
  579. end if
  580. ! If all four points are missing, try the next interpolation method in the sequence
  581. if (fxfy == 0.0 .and. fxcy == 0.0 .and. cxfy == 0.0 .and. cxcy == 0.0) then
  582. wt_four_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  583. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  584. else
  585. wt_four_pt_average = (fxfy * array(ifx, ify, izz) + &
  586. fxcy * array(ifx, icy, izz) + &
  587. cxfy * array(icx, ify, izz) + &
  588. cxcy * array(icx, icy, izz) ) / (fxfy + fxcy + cxfy + cxcy)
  589. end if
  590. end function wt_four_pt_average
  591. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  592. ! Name: sixteen_pt_average
  593. !
  594. ! Purpose: Average of sixteen surrounding grid point values
  595. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  596. recursive function sixteen_pt_average(xx, yy, izz, array, start_x, end_x, &
  597. start_y, end_y, start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  598. implicit none
  599. ! Arguments
  600. integer, intent(in) :: start_x, start_y, start_z
  601. integer, intent(in) :: end_x, end_y, end_z
  602. integer, intent(in) :: izz ! The z-index of the 2d-array to
  603. ! interpolate within
  604. real, intent(in) :: xx , yy ! The location to interpolate to
  605. real, intent(in) :: msgval
  606. real, intent(in), optional :: maskval
  607. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
  608. intent(in) :: array
  609. integer, dimension(:), intent(in) :: interp_list
  610. integer, intent(in) :: idx
  611. real, dimension(start_x:end_x, start_y:end_y), &
  612. intent(in), optional :: mask_array
  613. character (len=1), intent(in), optional :: mask_relational
  614. ! Return value
  615. real :: sixteen_pt_average
  616. ! Local variables
  617. integer :: i, j, ifx, ify
  618. real :: sum, sum_weight
  619. real, dimension(4,4) :: weights
  620. ifx = floor(xx)
  621. ify = floor(yy)
  622. ! First see whether the point is far enough within the array to
  623. ! allow for a sixteen point average.
  624. if (ifx < start_x+1 .or. ifx > end_x-2 .or. &
  625. ify < start_y+1 .or. ify > end_y-2) then
  626. sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  627. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  628. return
  629. end if
  630. sum_weight = 0.0
  631. do i=1,4
  632. do j=1,4
  633. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  634. if (mask_relational == '>' .and. mask_array(ifx+3-i, ify+3-j) > maskval) then
  635. weights(i,j) = 0.0
  636. else if (mask_relational == '<' .and. mask_array(ifx+3-i, ify+3-j) < maskval) then
  637. weights(i,j) = 0.0
  638. else if (mask_relational == ' ' .and. mask_array(ifx+3-i, ify+3-j) == maskval) then
  639. weights(i,j) = 0.0
  640. else
  641. weights(i,j) = 1.0
  642. end if
  643. if (array(ifx+3-i, ify+3-j, izz) == msgval) weights(i,j) = 0.0
  644. else if (present(mask_array) .and. present(maskval)) then
  645. if (array(ifx+3-i, ify+3-j, izz) == msgval .or. mask_array(ifx+3-i, ify+3-j) == maskval) then
  646. weights(i,j) = 0.0
  647. else
  648. weights(i,j) = 1.0
  649. end if
  650. else
  651. if (array(ifx+3-i, ify+3-j, izz) == msgval) then
  652. weights(i,j) = 0.0
  653. else
  654. weights(i,j) = 1.0
  655. end if
  656. end if
  657. sum_weight = sum_weight + weights(i,j)
  658. end do
  659. end do
  660. ! If all points are missing, try the next interpolation method in the sequence
  661. if (sum_weight == 0.0) then
  662. sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  663. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  664. else
  665. sum = 0.0
  666. do i=1,4
  667. do j=1,4
  668. sum = sum + weights(i,j) * array(ifx+3-i, ify+3-j, izz)
  669. end do
  670. end do
  671. sixteen_pt_average = sum / sum_weight
  672. end if
  673. end function sixteen_pt_average
  674. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  675. ! Name: wt_sixteen_pt_average
  676. !
  677. ! Purpose: Weighted average of sixteen surrounding grid point values
  678. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  679. recursive function wt_sixteen_pt_average(xx, yy, izz, array, start_x, end_x, &
  680. start_y, end_y, start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  681. implicit none
  682. ! Arguments
  683. integer, intent(in) :: start_x, start_y, start_z
  684. integer, intent(in) :: end_x, end_y, end_z
  685. integer, intent(in) :: izz ! The z-index of the 2d-array to
  686. ! interpolate within
  687. real, intent(in) :: xx , yy ! The location to interpolate to
  688. real, intent(in) :: msgval
  689. real, intent(in), optional :: maskval
  690. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
  691. intent(in) :: array
  692. integer, dimension(:), intent(in) :: interp_list
  693. integer, intent(in) :: idx
  694. real, dimension(start_x:end_x, start_y:end_y), &
  695. intent(in), optional :: mask_array
  696. character (len=1), intent(in), optional :: mask_relational
  697. ! Return value
  698. real :: wt_sixteen_pt_average
  699. ! Local variables
  700. integer :: i, j, ifx, ify
  701. real :: sum, sum_weight
  702. real, dimension(4,4) :: weights
  703. ifx = floor(xx)
  704. ify = floor(yy)
  705. ! First see whether the point is far enough within the array to
  706. ! allow for a sixteen point average.
  707. if (ifx < start_x+1 .or. ifx > end_x-2 .or. &
  708. ify < start_y+1 .or. ify > end_y-2) then
  709. wt_sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  710. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  711. return
  712. end if
  713. sum_weight = 0.0
  714. do i=1,4
  715. do j=1,4
  716. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  717. if (mask_relational == '>' .and. mask_array(ifx+3-i, ify+3-j) > maskval) then
  718. weights(i,j) = 0.0
  719. else if (mask_relational == '<' .and. mask_array(ifx+3-i, ify+3-j) < maskval) then
  720. weights(i,j) = 0.0
  721. else if (mask_relational == ' ' .and. mask_array(ifx+3-i, ify+3-j) == maskval) then
  722. weights(i,j) = 0.0
  723. else
  724. weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2))
  725. end if
  726. if (array(ifx+3-i, ify+3-j, izz) == msgval) weights(i,j) = 0.0
  727. else if (present(mask_array) .and. present(maskval)) then
  728. if (array(ifx+3-i, ify+3-j, izz) == msgval .or. mask_array(ifx+3-i, ify+3-j) == maskval) then
  729. weights(i,j) = 0.0
  730. else
  731. weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2))
  732. end if
  733. else
  734. if (array(ifx+3-i, ify+3-j, izz) == msgval) then
  735. weights(i,j) = 0.0
  736. else
  737. weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2))
  738. end if
  739. end if
  740. sum_weight = sum_weight + weights(i,j)
  741. end do
  742. end do
  743. ! If all points are missing, try the next interpolation method in the sequence
  744. if (sum_weight == 0.0) then
  745. wt_sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  746. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  747. else
  748. sum = 0.0
  749. do i=1,4
  750. do j=1,4
  751. sum = sum + weights(i,j) * array(ifx+3-i, ify+3-j, izz)
  752. end do
  753. end do
  754. wt_sixteen_pt_average = sum / sum_weight
  755. end if
  756. end function wt_sixteen_pt_average
  757. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  758. ! Name: four_pt
  759. !
  760. ! Purpose: Bilinear interpolation among four grid values
  761. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  762. recursive function four_pt(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  763. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  764. implicit none
  765. ! Arguments
  766. integer, intent(in) :: start_x, start_y, start_z
  767. integer, intent(in) :: end_x, end_y, end_z
  768. integer, intent(in) :: izz ! The z-index of the 2d-array to
  769. ! interpolate within
  770. real, intent(in) :: xx , yy ! The location to interpolate to
  771. real, intent(in) :: msgval
  772. real, intent(in), optional :: maskval
  773. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(in) :: array
  774. integer, dimension(:), intent(in) :: interp_list
  775. integer, intent(in) :: idx
  776. real, dimension(start_x:end_x, start_y:end_y), intent(in), optional :: mask_array
  777. character (len=1), intent(in), optional :: mask_relational
  778. ! Return value
  779. real :: four_pt
  780. ! Local variables
  781. integer :: min_x, min_y, max_x, max_y
  782. min_x = floor(xx)
  783. min_y = floor(yy)
  784. max_x = ceiling(xx)
  785. max_y = ceiling(yy)
  786. if (min_x < start_x .or. max_x > end_x) then
  787. four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, &
  788. msgval, interp_list, idx, mask_relational, maskval, mask_array)
  789. return
  790. end if
  791. if (min_y < start_y .or. max_y > end_y) then
  792. four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, &
  793. msgval, interp_list, idx, mask_relational, maskval, mask_array)
  794. return
  795. end if
  796. ! If we have a missing value, try the next interpolation method in the sequence
  797. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  798. ! we determine which maskval is useable by... if the symbol > is found, then only
  799. ! values less than 'maskval' can be used and if the symbol < is found,
  800. ! then only the values greater than 'maskval' can be used.
  801. if (mask_relational == '>' ) then
  802. if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) > maskval .or. &
  803. array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) > maskval .or. &
  804. array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) > maskval .or. &
  805. array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) > maskval) then
  806. four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, &
  807. msgval, interp_list, idx, mask_relational, maskval, mask_array)
  808. return
  809. end if
  810. else if (mask_relational == '<' ) then
  811. if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) < maskval .or. &
  812. array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) < maskval .or. &
  813. array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) < maskval .or. &
  814. array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) < maskval) then
  815. four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, &
  816. msgval, interp_list, idx, mask_relational, maskval, mask_array)
  817. return
  818. end if
  819. else if (mask_relational == ' ' ) then
  820. if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) == maskval .or. &
  821. array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) == maskval .or. &
  822. array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) == maskval .or. &
  823. array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) == maskval) then
  824. four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, &
  825. msgval, interp_list, idx, mask_relational, maskval, mask_array)
  826. return
  827. end if
  828. end if
  829. else if (present(mask_array) .and. present(maskval)) then
  830. if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) == maskval .or. &
  831. array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) == maskval .or. &
  832. array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) == maskval .or. &
  833. array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) == maskval) then
  834. four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, &
  835. msgval, interp_list, idx, mask_relational, maskval, mask_array)
  836. end if
  837. else
  838. if (array(min_x,min_y,izz) == msgval .or. &
  839. array(max_x,min_y,izz) == msgval .or. &
  840. array(min_x,max_y,izz) == msgval .or. &
  841. array(max_x,max_y,izz) == msgval ) then
  842. four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  843. start_z, end_z, msgval, interp_list, idx)
  844. return
  845. end if
  846. end if
  847. if (min_x == max_x) then
  848. if (min_y == max_y) then
  849. four_pt = array(min_x,min_y,izz)
  850. else
  851. four_pt = array(min_x,min_y,izz)*(real(max_y)-yy) + &
  852. array(min_x,max_y,izz)*(yy-real(min_y))
  853. end if
  854. else if (min_y == max_y) then
  855. if (min_x == max_x) then
  856. four_pt = array(min_x,min_y,izz)
  857. else
  858. four_pt = array(min_x,min_y,izz)*(real(max_x)-xx) + &
  859. array(max_x,min_y,izz)*(xx-real(min_x))
  860. end if
  861. else
  862. four_pt = (yy - min_y) * (array(min_x,max_y,izz)*(real(max_x)-xx) + &
  863. array(max_x,max_y,izz)*(xx-real(min_x))) + &
  864. (max_y - yy) * (array(min_x,min_y,izz)*(real(max_x)-xx) + &
  865. array(max_x,min_y,izz)*(xx-real(min_x)));
  866. end if
  867. end function four_pt
  868. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  869. ! Name: sixteen_pt
  870. !
  871. ! Purpose: Overlapping parabolic interpolation among sixteen grid values
  872. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  873. recursive function sixteen_pt(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, &
  874. msgval, interp_list, idx, mask_relational, maskval, mask_array)
  875. implicit none
  876. ! Arguments
  877. integer, intent(in) :: izz ! z-index of 2d-array to interpolate within
  878. integer, intent(in) :: start_x, start_y, start_z
  879. integer, intent(in) :: end_x, end_y, end_z
  880. real, intent(in) :: xx , yy ! The location to interpolate to
  881. real, intent(in) :: msgval
  882. real, intent(in), optional :: maskval
  883. real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), &
  884. intent(in) :: array
  885. integer, dimension(:), intent(in) :: interp_list
  886. integer, intent(in) :: idx
  887. real, dimension(start_x:end_x, start_y:end_y), &
  888. intent(in), optional :: mask_array
  889. character (len=1), intent(in), optional :: mask_relational
  890. ! Return value
  891. real :: sixteen_pt
  892. ! Local variables
  893. integer :: n , i , j , k , kk , l , ll
  894. real :: x , y , a , b , c , d , e , f , g , h
  895. real, dimension(4,4) :: stl
  896. logical :: is_masked
  897. is_masked = .false.
  898. if (int(xx) < start_x .or. int(xx) > end_x .or. &
  899. int(yy) < start_y .or. int(yy) > end_y) then
  900. sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  901. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  902. return
  903. end if
  904. sixteen_pt = 0.0
  905. n = 0
  906. i = int(xx + 0.00001)
  907. j = int(yy + 0.00001)
  908. x = xx - i
  909. y = yy - j
  910. if ( ( abs(x) > 0.0001 ) .or. ( abs(y) > 0.0001 ) ) then
  911. loop_1 : do k = 1,4
  912. kk = i + k - 2
  913. if ( kk < start_x) then
  914. kk = start_x
  915. else if ( kk > end_x) then
  916. kk = end_x
  917. end if
  918. loop_2 : do l = 1,4
  919. stl(k,l) = 0.
  920. ll = j + l - 2
  921. if ( ll < start_y ) then
  922. ll = start_y
  923. else if ( ll > end_y) then
  924. ll = end_y
  925. end if
  926. stl(k,l) = array(kk,ll,izz)
  927. n = n + 1
  928. if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then
  929. if (mask_relational == '>' .and. mask_array(kk,ll) > maskval) then
  930. is_masked = .true.
  931. else if (mask_relational == '<' .and. mask_array(kk,ll) < maskval) then
  932. is_masked = .true.
  933. else if (mask_relational == ' ' .and. mask_array(kk,ll) == maskval) then
  934. is_masked = .true.
  935. end if
  936. else if (present(mask_array) .and. present(maskval)) then
  937. if (mask_array(kk,ll) == maskval) is_masked = .true.
  938. end if
  939. if ( stl(k,l) == 0. .and. msgval /= 0.) then
  940. stl(k,l) = 1.E-20
  941. end if
  942. end do loop_2
  943. end do loop_1
  944. ! If we have a missing value, try the next interpolation method in the sequence
  945. if (present(mask_array) .and. present(maskval)) then
  946. do k=1,4
  947. do l=1,4
  948. if (stl(k,l) == msgval .or. is_masked) then
  949. sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, &
  950. start_z, end_z, msgval, interp_list, idx, mask_relational, maskval, mask_array)
  951. return
  952. end if
  953. end do
  954. end do
  955. else
  956. do k=1,4
  957. do l=1,4
  958. if (stl(k,l) == msgval) then
  959. sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y,

Large files files are truncated, but you can click here to view the full file