PageRenderTime 59ms CodeModel.GetById 24ms RepoModel.GetById 0ms app.codeStats 1ms

/WPS/metgrid/src/storage_module.F

http://github.com/jbeezley/wrf-fire
FORTRAN Legacy | 1102 lines | 662 code | 219 blank | 221 comment | 137 complexity | 41858da26e6956220b087b0957b3f168 MD5 | raw file
Possible License(s): AGPL-1.0
  1. module storage_module
  2. use datatype_module
  3. use minheap_module
  4. use misc_definitions_module
  5. use module_debug
  6. use parallel_module
  7. ! Maximum umber of words to keep in memory at a time
  8. ! THIS MUST BE AT LEAST AS LARGE AS THE SIZE OF THE LARGEST ARRAY TO BE STORED
  9. integer, parameter :: MEMSIZE_MAX = 1E9
  10. ! Name (when formatted as i9.9) of next file to be used as array storage
  11. integer :: next_filenumber = 1
  12. ! Time counter used by policy for evicting arrays to Fortran units
  13. integer :: global_time = 0
  14. ! Current memory usage of module
  15. integer :: memsize = 0
  16. ! Primary head and tail pointers
  17. type (head_node), pointer :: head => null()
  18. type (head_node), pointer :: tail => null()
  19. ! Pointer for get_next_output_fieldname
  20. type (head_node), pointer :: next_output_field => null()
  21. contains
  22. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  23. ! Name: storage_init
  24. !
  25. ! Purpose: Initialize the storage module.
  26. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  27. subroutine storage_init()
  28. implicit none
  29. call init_heap()
  30. end subroutine storage_init
  31. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  32. ! Name: reset_next_field
  33. !
  34. ! Purpose: Sets the next field to the first available field
  35. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  36. subroutine reset_next_field()
  37. implicit none
  38. next_output_field => head
  39. end subroutine reset_next_field
  40. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  41. ! Name: storage_put_field
  42. !
  43. ! Purpose: Stores an fg_input type. Upon return, IT MUST NOT BE ASSUMED that
  44. ! store_me contains valid data, since all such data may have been written
  45. ! to a Fortran unit
  46. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  47. subroutine storage_put_field(store_me)
  48. implicit none
  49. ! Arguments
  50. type (fg_input), intent(in) :: store_me
  51. ! Local variables
  52. integer :: funit
  53. logical :: is_used
  54. character (len=64) :: fname
  55. type (head_node), pointer :: name_cursor
  56. type (data_node), pointer :: data_cursor
  57. type (data_node), pointer :: newnode
  58. type (data_node), pointer :: evictnode
  59. ! We'll first see if there is already a list for this fieldname
  60. name_cursor => head
  61. do while (associated(name_cursor))
  62. if (primary_cmp(name_cursor%fg_data, store_me) == EQUAL) exit
  63. name_cursor => name_cursor%next
  64. end do
  65. ! If not, create a new node in the primary list
  66. if (.not. associated(name_cursor)) then
  67. allocate(name_cursor)
  68. call dup(store_me, name_cursor%fg_data)
  69. nullify(name_cursor%fg_data%r_arr)
  70. nullify(name_cursor%fg_data%valid_mask)
  71. nullify(name_cursor%fg_data%modified_mask)
  72. nullify(name_cursor%fieldlist_head)
  73. nullify(name_cursor%fieldlist_tail)
  74. nullify(name_cursor%prev)
  75. name_cursor%next => head
  76. if (.not. associated(head)) tail => name_cursor
  77. head => name_cursor
  78. else
  79. if ((name_cursor%fg_data%header%time_dependent .and. .not. store_me%header%time_dependent) .or. &
  80. (.not. name_cursor%fg_data%header%time_dependent .and. store_me%header%time_dependent)) then
  81. call mprintf(.true.,ERROR,'Cannot combine time-independent data with '// &
  82. 'time-dependent data for field %s',s1=store_me%header%field)
  83. end if
  84. end if
  85. ! At this point, name_cursor points to a valid head node for fieldname
  86. data_cursor => name_cursor%fieldlist_head
  87. do while ( associated(data_cursor) )
  88. if ((secondary_cmp(store_me, data_cursor%fg_data) == LESS) .or. &
  89. (secondary_cmp(store_me, data_cursor%fg_data) == EQUAL)) exit
  90. data_cursor => data_cursor%next
  91. end do
  92. if (associated(data_cursor)) then
  93. if (secondary_cmp(store_me, data_cursor%fg_data) == EQUAL) then
  94. if (data_cursor%filenumber > 0) then
  95. ! BUG: Might need to deal with freeing up a file
  96. call mprintf(.true.,WARN,'WE NEED TO FREE THE FILE ASSOCIATED WITH DATA_CURSOR')
  97. call mprintf(.true.,WARN,'PLEASE REPORT THIS BUG TO THE DEVELOPER!')
  98. end if
  99. data_cursor%fg_data%r_arr => store_me%r_arr
  100. data_cursor%fg_data%valid_mask => store_me%valid_mask
  101. data_cursor%fg_data%modified_mask => store_me%modified_mask
  102. return
  103. end if
  104. end if
  105. allocate(newnode)
  106. call dup(store_me, newnode%fg_data)
  107. newnode%field_shape = shape(newnode%fg_data%r_arr)
  108. memsize = memsize + size(newnode%fg_data%r_arr)
  109. newnode%last_used = global_time
  110. global_time = global_time + 1
  111. newnode%filenumber = 0
  112. call add_to_heap(newnode)
  113. do while (memsize > MEMSIZE_MAX)
  114. call get_min(evictnode)
  115. evictnode%filenumber = next_filenumber
  116. next_filenumber = next_filenumber + 1
  117. do funit=10,100
  118. inquire(unit=funit, opened=is_used)
  119. if (.not. is_used) exit
  120. end do
  121. memsize = memsize - size(evictnode%fg_data%r_arr)
  122. write(fname,'(i9.9,a2,i3.3)') evictnode%filenumber,'.p',my_proc_id
  123. open(funit,file=trim(fname),form='unformatted',status='unknown')
  124. write(funit) evictnode%fg_data%r_arr
  125. close(funit)
  126. deallocate(evictnode%fg_data%r_arr)
  127. end do
  128. ! Inserting node at the tail of list
  129. if (.not. associated(data_cursor)) then
  130. newnode%prev => name_cursor%fieldlist_tail
  131. nullify(newnode%next)
  132. ! List is actually empty
  133. if (.not. associated(name_cursor%fieldlist_head)) then
  134. name_cursor%fieldlist_head => newnode
  135. name_cursor%fieldlist_tail => newnode
  136. else
  137. name_cursor%fieldlist_tail%next => newnode
  138. name_cursor%fieldlist_tail => newnode
  139. end if
  140. ! Inserting node at the head of list
  141. else if ((secondary_cmp(name_cursor%fieldlist_head%fg_data, newnode%fg_data) == GREATER) .or. &
  142. (secondary_cmp(name_cursor%fieldlist_head%fg_data, newnode%fg_data) == EQUAL)) then
  143. nullify(newnode%prev)
  144. newnode%next => name_cursor%fieldlist_head
  145. name_cursor%fieldlist_head%prev => newnode
  146. name_cursor%fieldlist_head => newnode
  147. ! Inserting somewhere in the middle of the list
  148. else
  149. newnode%prev => data_cursor%prev
  150. newnode%next => data_cursor
  151. data_cursor%prev%next => newnode
  152. data_cursor%prev => newnode
  153. end if
  154. end subroutine storage_put_field
  155. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  156. ! Name: storage_get_field
  157. !
  158. ! Purpose: Retrieves an fg_input type from storage; if the fg_input type whose
  159. ! header matches the header of get_me does not exist, istatus = 1 upon
  160. ! return; if the requested fg_input type is found, istatus = 0
  161. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  162. subroutine storage_get_field(get_me, istatus)
  163. implicit none
  164. ! Arguments
  165. type (fg_input), intent(inout) :: get_me
  166. integer, intent(out) :: istatus
  167. ! Local variables
  168. integer :: funit
  169. logical :: is_used
  170. character (len=64) :: fname
  171. type (head_node), pointer :: name_cursor
  172. type (data_node), pointer :: data_cursor
  173. type (data_node), pointer :: evictnode
  174. global_time = global_time + 1
  175. istatus = 1
  176. ! We'll first see if there is already a list for this fieldname
  177. name_cursor => head
  178. do while (associated(name_cursor))
  179. if (primary_cmp(name_cursor%fg_data, get_me) == EQUAL) exit
  180. name_cursor => name_cursor%next
  181. end do
  182. if (.not. associated(name_cursor)) return
  183. ! At this point, name_cursor points to a valid head node for fieldname
  184. data_cursor => name_cursor%fieldlist_head
  185. do while ( associated(data_cursor) )
  186. if (secondary_cmp(get_me, data_cursor%fg_data) == EQUAL) then
  187. call dup(data_cursor%fg_data, get_me)
  188. ! Before deciding whether we need to write an array to disk, first consider
  189. ! that reading the requested array will use memory
  190. if (data_cursor%filenumber > 0) then
  191. memsize = memsize + data_cursor%field_shape(1)*data_cursor%field_shape(2)
  192. end if
  193. ! If we exceed our memory limit, we need to evict
  194. do while (memsize > MEMSIZE_MAX)
  195. call get_min(evictnode)
  196. evictnode%filenumber = next_filenumber
  197. next_filenumber = next_filenumber + 1
  198. do funit=10,100
  199. inquire(unit=funit, opened=is_used)
  200. if (.not. is_used) exit
  201. end do
  202. memsize = memsize - size(evictnode%fg_data%r_arr)
  203. write(fname,'(i9.9,a2,i3.3)') evictnode%filenumber,'.p',my_proc_id
  204. open(funit,file=trim(fname),form='unformatted',status='unknown')
  205. write(funit) evictnode%fg_data%r_arr
  206. close(funit)
  207. deallocate(evictnode%fg_data%r_arr)
  208. end do
  209. ! Get requested array
  210. if (data_cursor%filenumber > 0) then
  211. data_cursor%last_used = global_time
  212. global_time = global_time + 1
  213. call add_to_heap(data_cursor)
  214. write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
  215. do funit=10,100
  216. inquire(unit=funit, opened=is_used)
  217. if (.not. is_used) exit
  218. end do
  219. open(funit,file=trim(fname),form='unformatted',status='old')
  220. allocate(data_cursor%fg_data%r_arr(data_cursor%field_shape(1),data_cursor%field_shape(2)))
  221. read(funit) data_cursor%fg_data%r_arr
  222. get_me%r_arr => data_cursor%fg_data%r_arr
  223. close(funit,status='delete')
  224. data_cursor%filenumber = 0
  225. else
  226. get_me%r_arr => data_cursor%fg_data%r_arr
  227. call remove_index(data_cursor%heap_index)
  228. data_cursor%last_used = global_time
  229. global_time = global_time + 1
  230. call add_to_heap(data_cursor)
  231. end if
  232. istatus = 0
  233. return
  234. end if
  235. data_cursor => data_cursor%next
  236. end do
  237. end subroutine storage_get_field
  238. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  239. ! Name: storage_query_field
  240. !
  241. ! Purpose:
  242. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  243. subroutine storage_query_field(get_me, istatus)
  244. implicit none
  245. ! Arguments
  246. type (fg_input), intent(inout) :: get_me
  247. integer, intent(out) :: istatus
  248. ! Local variables
  249. type (head_node), pointer :: name_cursor
  250. type (data_node), pointer :: data_cursor
  251. istatus = 1
  252. ! We'll first see if there is already a list for this fieldname
  253. name_cursor => head
  254. do while (associated(name_cursor))
  255. if (primary_cmp(name_cursor%fg_data, get_me) == EQUAL) exit
  256. name_cursor => name_cursor%next
  257. end do
  258. if (.not. associated(name_cursor)) return
  259. ! At this point, name_cursor points to a valid head node for fieldname
  260. data_cursor => name_cursor%fieldlist_head
  261. do while ( associated(data_cursor) )
  262. if (secondary_cmp(get_me, data_cursor%fg_data) == EQUAL) then
  263. get_me%r_arr => data_cursor%fg_data%r_arr
  264. get_me%valid_mask => data_cursor%fg_data%valid_mask
  265. get_me%modified_mask => data_cursor%fg_data%modified_mask
  266. istatus = 0
  267. return
  268. end if
  269. data_cursor => data_cursor%next
  270. end do
  271. end subroutine storage_query_field
  272. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  273. ! Name: get_next_output_fieldname
  274. !
  275. ! Purpose:
  276. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  277. subroutine get_next_output_fieldname(nest_num, field_name, ndims, &
  278. min_level, max_level, &
  279. istagger, mem_order, dim_names, units, description, &
  280. subgrid_var, &
  281. istatus)
  282. implicit none
  283. ! Arguments
  284. integer, intent(in) :: nest_num
  285. integer, intent(out) :: ndims, min_level, max_level, istagger, istatus
  286. logical, intent(out) :: subgrid_var
  287. character (len=128), intent(out) :: field_name, mem_order, units, description
  288. character (len=128), dimension(3), intent(out) :: dim_names
  289. #include "wrf_io_flags.h"
  290. #include "wrf_status_codes.h"
  291. ! Local variables
  292. type (data_node), pointer :: data_cursor
  293. istatus = 1
  294. if (.not. associated(next_output_field)) return
  295. min_level = 1
  296. max_level = 0
  297. ndims = 2
  298. do while (max_level == 0 .and. associated(next_output_field))
  299. data_cursor => next_output_field%fieldlist_head
  300. if (associated(data_cursor)) then
  301. if (.not. is_mask_field(data_cursor%fg_data)) then
  302. do while ( associated(data_cursor) )
  303. istatus = 0
  304. max_level = max_level + 1
  305. data_cursor => data_cursor%next
  306. end do
  307. end if
  308. end if
  309. if (max_level == 0) next_output_field => next_output_field%next
  310. end do
  311. if (max_level > 0 .and. associated(next_output_field)) then
  312. if (max_level > 1) ndims = 3
  313. if (ndims == 2) then
  314. mem_order = 'XY '
  315. dim_names(3) = ' '
  316. else
  317. mem_order = 'XYZ'
  318. if (is_time_dependent(next_output_field%fg_data)) then
  319. dim_names(3) = ' '
  320. dim_names(3)(1:32) = next_output_field%fg_data%header%vertical_coord
  321. else
  322. write(dim_names(3),'(a11,i4.4)') 'z-dimension', max_level
  323. end if
  324. end if
  325. field_name = get_fieldname(next_output_field%fg_data)
  326. istagger = get_staggering(next_output_field%fg_data)
  327. if (istagger == M .or. istagger == HH .or. istagger == VV) then
  328. dim_names(1) = 'west_east'
  329. dim_names(2) = 'south_north'
  330. else if (istagger == U) then
  331. dim_names(1) = 'west_east_stag'
  332. dim_names(2) = 'south_north'
  333. else if (istagger == V) then
  334. dim_names(1) = 'west_east'
  335. dim_names(2) = 'south_north_stag'
  336. else
  337. dim_names(1) = 'i-dimension'
  338. dim_names(2) = 'j-dimension'
  339. end if
  340. units = get_units(next_output_field%fg_data)
  341. description = get_description(next_output_field%fg_data)
  342. subgrid_var=is_subgrid_var(field_name)
  343. if (subgrid_var) call get_subgrid_dim_name(dim_names(1:2))
  344. next_output_field => next_output_field%next
  345. end if
  346. end subroutine get_next_output_fieldname
  347. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  348. ! Name: get_subgrid_dim_name
  349. !
  350. ! Purpose:
  351. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  352. logical function is_subgrid_var(field_name)
  353. use gridinfo_module
  354. implicit none
  355. ! Arguments
  356. character(len=128), intent(in) :: field_name
  357. is_subgrid_var=next_output_field%fg_data%header%is_subgrid
  358. end function is_subgrid_var
  359. subroutine get_subgrid_dim_name(dimnames)
  360. implicit none
  361. character(len=128),dimension(2),intent(out)::dimnames
  362. dimnames(1)='west_east_subgrid'
  363. dimnames(2)='south_north_subgrid'
  364. end subroutine get_subgrid_dim_name
  365. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  366. ! Name: get_next_output_field
  367. !
  368. ! Purpose:
  369. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  370. subroutine get_next_output_field(field_name, r_array, &
  371. start_i, end_i, start_j, end_j, min_level, max_level, istatus)
  372. implicit none
  373. ! Arguments
  374. integer, intent(out) :: start_i, end_i, start_j, end_j, min_level, max_level, istatus
  375. real, pointer, dimension(:,:,:) :: r_array
  376. character (len=128), intent(out) :: field_name
  377. #include "wrf_io_flags.h"
  378. #include "wrf_status_codes.h"
  379. ! Local variables
  380. integer :: k
  381. type (data_node), pointer :: data_cursor
  382. type (fg_input) :: temp_field
  383. istatus = 1
  384. if (.not. associated(next_output_field)) return
  385. min_level = 1
  386. max_level = 0
  387. do while (max_level == 0 .and. associated(next_output_field))
  388. data_cursor => next_output_field%fieldlist_head
  389. if (associated(data_cursor)) then
  390. if (.not. is_mask_field(data_cursor%fg_data)) then
  391. do while ( associated(data_cursor) )
  392. istatus = 0
  393. max_level = max_level + 1
  394. data_cursor => data_cursor%next
  395. end do
  396. end if
  397. end if
  398. if (max_level == 0) next_output_field => next_output_field%next
  399. end do
  400. if (max_level > 0 .and. associated(next_output_field)) then
  401. start_i = 1
  402. end_i = next_output_field%fieldlist_head%field_shape(1)
  403. start_j = 1
  404. end_j = next_output_field%fieldlist_head%field_shape(2)
  405. allocate(r_array(next_output_field%fieldlist_head%field_shape(1), &
  406. next_output_field%fieldlist_head%field_shape(2), &
  407. max_level) )
  408. k = 1
  409. data_cursor => next_output_field%fieldlist_head
  410. do while ( associated(data_cursor) )
  411. call dup(data_cursor%fg_data, temp_field)
  412. call storage_get_field(temp_field, istatus)
  413. r_array(:,:,k) = temp_field%r_arr
  414. k = k + 1
  415. data_cursor => data_cursor%next
  416. end do
  417. field_name = get_fieldname(next_output_field%fg_data)
  418. next_output_field => next_output_field%next
  419. end if
  420. end subroutine get_next_output_field
  421. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  422. ! Name: storage_delete_field
  423. !
  424. ! Purpose: Deletes the stored fg_input type whose header matches delete_me
  425. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  426. subroutine storage_delete_field(delete_me)
  427. implicit none
  428. ! Arguments
  429. type (fg_input), intent(in) :: delete_me
  430. ! Local variables
  431. integer :: funit
  432. logical :: is_used
  433. character (len=64) :: fname
  434. type (head_node), pointer :: name_cursor
  435. type (data_node), pointer :: data_cursor
  436. ! We'll first see if there is a list for this fieldname
  437. name_cursor => head
  438. do while (associated(name_cursor))
  439. if (primary_cmp(name_cursor%fg_data, delete_me) == EQUAL) exit
  440. name_cursor => name_cursor%next
  441. end do
  442. if (.not. associated(name_cursor)) return
  443. ! At this point, name_cursor points to a valid head node for fieldname
  444. data_cursor => name_cursor%fieldlist_head
  445. do while ( associated(data_cursor) )
  446. if (secondary_cmp(delete_me, data_cursor%fg_data) == EQUAL) then
  447. if (data_cursor%filenumber > 0) then
  448. do funit=10,100
  449. inquire(unit=funit, opened=is_used)
  450. if (.not. is_used) exit
  451. end do
  452. write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
  453. open(funit,file=trim(fname),form='unformatted',status='old')
  454. close(funit,status='delete')
  455. else
  456. call remove_index(data_cursor%heap_index)
  457. memsize = memsize - size(data_cursor%fg_data%r_arr)
  458. deallocate(data_cursor%fg_data%r_arr)
  459. end if
  460. if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask)
  461. nullify(data_cursor%fg_data%valid_mask)
  462. if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask)
  463. nullify(data_cursor%fg_data%modified_mask)
  464. ! Only item in the list
  465. if (.not. associated(data_cursor%next) .and. &
  466. .not. associated(data_cursor%prev)) then
  467. nullify(name_cursor%fieldlist_head)
  468. nullify(name_cursor%fieldlist_tail)
  469. deallocate(data_cursor)
  470. ! DO WE REMOVE THIS HEADER NODE AT THIS POINT?
  471. return
  472. ! Head of the list
  473. else if (.not. associated(data_cursor%prev)) then
  474. name_cursor%fieldlist_head => data_cursor%next
  475. nullify(data_cursor%next%prev)
  476. deallocate(data_cursor)
  477. return
  478. ! Tail of the list
  479. else if (.not. associated(data_cursor%next)) then
  480. name_cursor%fieldlist_tail => data_cursor%prev
  481. nullify(data_cursor%prev%next)
  482. deallocate(data_cursor)
  483. return
  484. ! Middle of the list
  485. else
  486. data_cursor%prev%next => data_cursor%next
  487. data_cursor%next%prev => data_cursor%prev
  488. deallocate(data_cursor)
  489. return
  490. end if
  491. end if
  492. data_cursor => data_cursor%next
  493. end do
  494. end subroutine storage_delete_field
  495. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  496. ! Name: storage_delete_all_td
  497. !
  498. ! Purpose: Deletes the stored time-dependent data
  499. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  500. subroutine storage_delete_all_td()
  501. implicit none
  502. ! Local variables
  503. integer :: funit
  504. logical :: is_used
  505. character (len=64) :: fname
  506. type (head_node), pointer :: name_cursor
  507. type (data_node), pointer :: data_cursor, next_cursor
  508. ! We'll first see if there is a list for this fieldname
  509. name_cursor => head
  510. do while (associated(name_cursor))
  511. data_cursor => name_cursor%fieldlist_head
  512. do while ( associated(data_cursor) )
  513. if ( is_time_dependent(data_cursor%fg_data) ) then
  514. if (data_cursor%filenumber > 0) then
  515. do funit=10,100
  516. inquire(unit=funit, opened=is_used)
  517. if (.not. is_used) exit
  518. end do
  519. write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
  520. open(funit,file=trim(fname),form='unformatted',status='old')
  521. close(funit,status='delete')
  522. else
  523. call remove_index(data_cursor%heap_index)
  524. memsize = memsize - size(data_cursor%fg_data%r_arr)
  525. deallocate(data_cursor%fg_data%r_arr)
  526. end if
  527. if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask)
  528. nullify(data_cursor%fg_data%valid_mask)
  529. if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask)
  530. nullify(data_cursor%fg_data%modified_mask)
  531. ! We should handle individual cases, that way we can deal with a list
  532. ! that has both time independent and time dependent nodes in it.
  533. ! Only item in the list
  534. if (.not. associated(data_cursor%next) .and. &
  535. .not. associated(data_cursor%prev)) then
  536. next_cursor => null()
  537. nullify(name_cursor%fieldlist_head)
  538. nullify(name_cursor%fieldlist_tail)
  539. deallocate(data_cursor)
  540. ! DO WE REMOVE THIS HEADER NODE AT THIS POINT?
  541. ! Head of the list
  542. else if (.not. associated(data_cursor%prev)) then
  543. name_cursor%fieldlist_head => data_cursor%next
  544. next_cursor => data_cursor%next
  545. nullify(data_cursor%next%prev)
  546. deallocate(data_cursor)
  547. ! Tail of the list
  548. else if (.not. associated(data_cursor%next)) then
  549. ! THIS CASE SHOULD PROBABLY NOT OCCUR
  550. name_cursor%fieldlist_tail => data_cursor%prev
  551. next_cursor => null()
  552. nullify(data_cursor%prev%next)
  553. deallocate(data_cursor)
  554. ! Middle of the list
  555. else
  556. ! THIS CASE SHOULD PROBABLY NOT OCCUR
  557. next_cursor => data_cursor%next
  558. data_cursor%prev%next => data_cursor%next
  559. data_cursor%next%prev => data_cursor%prev
  560. deallocate(data_cursor)
  561. end if
  562. end if
  563. data_cursor => next_cursor
  564. end do
  565. name_cursor => name_cursor%next
  566. end do
  567. end subroutine storage_delete_all_td
  568. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  569. ! Name: storage_get_levels
  570. !
  571. ! Purpose: Returns a list of all levels for the field indicated in the_header.
  572. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  573. subroutine storage_get_levels(the_header, list)
  574. implicit none
  575. ! Arguments
  576. integer, pointer, dimension(:) :: list
  577. type (fg_input), intent(in) :: the_header
  578. ! Local variables
  579. integer :: n
  580. type (head_node), pointer :: name_cursor
  581. type (data_node), pointer :: data_cursor
  582. if (associated(list)) deallocate(list)
  583. nullify(list)
  584. ! We'll first see if there is a list for this header
  585. name_cursor => head
  586. do while (associated(name_cursor))
  587. if (primary_cmp(name_cursor%fg_data, the_header) == EQUAL) exit
  588. name_cursor => name_cursor%next
  589. end do
  590. if (.not. associated(name_cursor)) return
  591. n = 0
  592. ! At this point, name_cursor points to a valid head node for fieldname
  593. data_cursor => name_cursor%fieldlist_head
  594. do while ( associated(data_cursor) )
  595. n = n + 1
  596. if (.not. associated(data_cursor%next)) exit
  597. data_cursor => data_cursor%next
  598. end do
  599. if (n > 0) allocate(list(n))
  600. n = 1
  601. do while ( associated(data_cursor) )
  602. list(n) = get_level(data_cursor%fg_data)
  603. n = n + 1
  604. data_cursor => data_cursor%prev
  605. end do
  606. end subroutine storage_get_levels
  607. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  608. ! Name: storage_delete_all
  609. !
  610. ! Purpose: Deletes all data, both time-independent and time-dependent.
  611. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  612. subroutine storage_delete_all()
  613. implicit none
  614. ! Local variables
  615. integer :: funit
  616. logical :: is_used
  617. character (len=64) :: fname
  618. type (head_node), pointer :: name_cursor
  619. type (data_node), pointer :: data_cursor
  620. ! We'll first see if there is already a list for this fieldname
  621. name_cursor => head
  622. do while (associated(name_cursor))
  623. if (associated(name_cursor%fieldlist_head)) then
  624. data_cursor => name_cursor%fieldlist_head
  625. do while ( associated(data_cursor) )
  626. name_cursor%fieldlist_head => data_cursor%next
  627. if (data_cursor%filenumber > 0) then
  628. do funit=10,100
  629. inquire(unit=funit, opened=is_used)
  630. if (.not. is_used) exit
  631. end do
  632. write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id
  633. open(funit,file=trim(fname),form='unformatted',status='old')
  634. close(funit,status='delete')
  635. else
  636. call remove_index(data_cursor%heap_index)
  637. memsize = memsize - size(data_cursor%fg_data%r_arr)
  638. deallocate(data_cursor%fg_data%r_arr)
  639. end if
  640. if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask)
  641. nullify(data_cursor%fg_data%valid_mask)
  642. if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask)
  643. nullify(data_cursor%fg_data%modified_mask)
  644. deallocate(data_cursor)
  645. data_cursor => name_cursor%fieldlist_head
  646. end do
  647. end if
  648. head => name_cursor%next
  649. deallocate(name_cursor)
  650. name_cursor => head
  651. end do
  652. nullify(head)
  653. nullify(tail)
  654. call heap_destroy()
  655. end subroutine storage_delete_all
  656. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  657. ! Name: storage_get_all_headers
  658. !
  659. ! Purpose:
  660. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  661. subroutine storage_get_all_headers(header_list)
  662. implicit none
  663. ! Arguments
  664. type (fg_input), pointer, dimension(:) :: header_list
  665. ! Local variables
  666. integer :: nheaders
  667. type (head_node), pointer :: name_cursor
  668. nullify(header_list)
  669. ! First find out how many time-dependent headers there are
  670. name_cursor => head
  671. nheaders = 0
  672. do while (associated(name_cursor))
  673. if (associated(name_cursor%fieldlist_head)) then
  674. if (.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
  675. nheaders = nheaders + 1
  676. end if
  677. end if
  678. name_cursor => name_cursor%next
  679. end do
  680. allocate(header_list(nheaders))
  681. name_cursor => head
  682. nheaders = 0
  683. do while (associated(name_cursor))
  684. if (associated(name_cursor%fieldlist_head)) then
  685. if (.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
  686. nheaders = nheaders + 1
  687. call dup(name_cursor%fieldlist_head%fg_data, header_list(nheaders))
  688. end if
  689. end if
  690. name_cursor => name_cursor%next
  691. end do
  692. end subroutine storage_get_all_headers
  693. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  694. ! Name: storage_get_all_td_headers
  695. !
  696. ! Purpose:
  697. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  698. subroutine storage_get_td_headers(header_list)
  699. implicit none
  700. ! Arguments
  701. type (fg_input), pointer, dimension(:) :: header_list
  702. ! Local variables
  703. integer :: nheaders
  704. type (head_node), pointer :: name_cursor
  705. nullify(header_list)
  706. ! First find out how many time-dependent headers there are
  707. name_cursor => head
  708. nheaders = 0
  709. do while (associated(name_cursor))
  710. if (associated(name_cursor%fieldlist_head)) then
  711. if (is_time_dependent(name_cursor%fieldlist_head%fg_data) .and. &
  712. .not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
  713. nheaders = nheaders + 1
  714. end if
  715. end if
  716. name_cursor => name_cursor%next
  717. end do
  718. allocate(header_list(nheaders))
  719. name_cursor => head
  720. nheaders = 0
  721. do while (associated(name_cursor))
  722. if (associated(name_cursor%fieldlist_head)) then
  723. if (is_time_dependent(name_cursor%fieldlist_head%fg_data) .and. &
  724. .not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then
  725. nheaders = nheaders + 1
  726. call dup(name_cursor%fieldlist_head%fg_data, header_list(nheaders))
  727. end if
  728. end if
  729. name_cursor => name_cursor%next
  730. end do
  731. end subroutine storage_get_td_headers
  732. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  733. ! Name: storage_print_fields
  734. !
  735. ! Purpose:
  736. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  737. subroutine storage_print_fields()
  738. use list_module
  739. use stringutil
  740. implicit none
  741. ! Local variables
  742. integer :: i, j, k, lmax, n_fields, n_levels, max_levels, itemp
  743. logical, allocatable, dimension(:,:) :: field_has_level
  744. integer, allocatable, dimension(:) :: all_levels
  745. integer, pointer, dimension(:) :: ilevels
  746. character (len=128), allocatable, dimension(:) :: fieldname_list
  747. character (len=9) :: ctemp
  748. type (fg_input), pointer, dimension(:) :: header_list
  749. type (list) :: all_levs
  750. call list_init(all_levs)
  751. call storage_get_td_headers(header_list)
  752. n_fields = size(header_list)
  753. allocate(fieldname_list(n_fields))
  754. max_levels = 0
  755. do i=1,n_fields
  756. fieldname_list(i) = header_list(i)%header%field
  757. call storage_get_levels(header_list(i), ilevels)
  758. do j=1,size(ilevels)
  759. if (.not. list_search(all_levs, ikey=ilevels(j), ivalue=itemp)) then
  760. call list_insert(all_levs, ikey=ilevels(j), ivalue=ilevels(j))
  761. end if
  762. end do
  763. n_levels = size(ilevels)
  764. if (n_levels > max_levels) max_levels = n_levels
  765. if (associated(ilevels)) deallocate(ilevels)
  766. end do
  767. max_levels = list_length(all_levs)
  768. allocate(all_levels(max_levels))
  769. allocate(field_has_level(n_fields,max_levels))
  770. field_has_level(:,:) = .false.
  771. lmax = 0
  772. do i=1,n_fields
  773. call storage_get_levels(header_list(i), ilevels)
  774. n_levels = size(ilevels)
  775. do j=1,n_levels
  776. do k=1,lmax
  777. if (all_levels(k) == ilevels(j)) exit
  778. end do
  779. if (k > lmax) then
  780. all_levels(k) = ilevels(j)
  781. lmax = lmax + 1
  782. end if
  783. field_has_level(i,k) = .true.
  784. end do
  785. if (associated(ilevels)) deallocate(ilevels)
  786. end do
  787. call mprintf(.true.,DEBUG,' .',newline=.false.)
  788. do i=1,n_fields
  789. write(ctemp,'(a9)') fieldname_list(i)(1:9)
  790. call right_justify(ctemp,9)
  791. call mprintf(.true.,DEBUG,ctemp,newline=.false.)
  792. end do
  793. call mprintf(.true.,DEBUG,' ',newline=.true.)
  794. do j=1,max_levels
  795. write(ctemp,'(i9)') all_levels(j)
  796. call mprintf(.true.,DEBUG,'%s ',s1=ctemp,newline=.false.)
  797. do i=1,n_fields
  798. if (field_has_level(i,j)) then
  799. call mprintf(.true.,DEBUG,' X',newline=.false.)
  800. else
  801. call mprintf(.true.,DEBUG,' -',newline=.false.)
  802. end if
  803. end do
  804. call mprintf(.true.,DEBUG,' ',newline=.true.)
  805. end do
  806. deallocate(all_levels)
  807. deallocate(field_has_level)
  808. deallocate(fieldname_list)
  809. deallocate(header_list)
  810. call list_destroy(all_levs)
  811. end subroutine storage_print_fields
  812. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  813. ! Name: find_missing_values
  814. !
  815. ! Purpose:
  816. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  817. subroutine find_missing_values()
  818. implicit none
  819. ! Local variables
  820. integer :: i, j
  821. logical :: found_missing
  822. type (head_node), pointer :: name_cursor
  823. type (data_node), pointer :: data_cursor
  824. found_missing = .false.
  825. name_cursor => head
  826. do while (associated(name_cursor))
  827. if (associated(name_cursor%fieldlist_head)) then
  828. data_cursor => name_cursor%fieldlist_head
  829. do while ( associated(data_cursor) )
  830. if (.not. associated(data_cursor%fg_data%valid_mask)) then
  831. call mprintf(.true.,INFORM, &
  832. 'Field %s does not have a valid mask and will not be checked for missing values', &
  833. s1=data_cursor%fg_data%header%field)
  834. else
  835. ILOOP: do i=1,data_cursor%fg_data%header%dim1(2)-data_cursor%fg_data%header%dim1(1)+1
  836. JLOOP: do j=1,data_cursor%fg_data%header%dim2(2)-data_cursor%fg_data%header%dim2(1)+1
  837. if (.not. bitarray_test(data_cursor%fg_data%valid_mask,i,j)) then
  838. found_missing = .true.
  839. call mprintf(.true.,WARN,'Field %s has missing values at level %i at (i,j)=(%i,%i)', &
  840. s1=data_cursor%fg_data%header%field, &
  841. i1=data_cursor%fg_data%header%vertical_level, &
  842. i2=i+data_cursor%fg_data%header%dim1(1)-1, &
  843. i3=j+data_cursor%fg_data%header%dim2(1)-1)
  844. exit ILOOP
  845. end if
  846. end do JLOOP
  847. end do ILOOP
  848. end if
  849. data_cursor => data_cursor%next
  850. end do
  851. end if
  852. name_cursor => name_cursor%next
  853. end do
  854. call mprintf(found_missing,ERROR,'Missing values encountered in interpolated fields. Stopping.')
  855. end subroutine find_missing_values
  856. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  857. ! Name: storage_print_headers
  858. !
  859. ! Purpose:
  860. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  861. subroutine storage_print_headers()
  862. implicit none
  863. ! Local variables
  864. type (head_node), pointer :: name_cursor
  865. type (data_node), pointer :: data_cursor
  866. call mprintf(.true.,DEBUG,'>>>> STORED FIELDS <<<<')
  867. call mprintf(.true.,DEBUG,'=======================')
  868. ! We'll first see if there is already a list for this fieldname
  869. name_cursor => head
  870. do while (associated(name_cursor))
  871. call print_header(name_cursor%fg_data)
  872. if (associated(name_cursor%fieldlist_head)) then
  873. data_cursor => name_cursor%fieldlist_head
  874. do while ( associated(data_cursor) )
  875. call mprintf(.true.,DEBUG,' - %i', i1=get_level(data_cursor%fg_data))
  876. call mprintf(.true.,DEBUG,' ')
  877. data_cursor => data_cursor%next
  878. end do
  879. end if
  880. name_cursor => name_cursor%next
  881. end do
  882. end subroutine storage_print_headers
  883. end module storage_module