MODFLOW 6  version 6.8.0.dev0
USGS Modular Hydrologic Model
MemoryManager.f90
Go to the documentation of this file.
2 
3  use kindmodule, only: dp, lgp, i4b, i8b
4  use constantsmodule, only: dzero, done, &
5  dem3, dem6, dem9, dep3, dep6, dep9, &
11  tabright
12  use simvariablesmodule, only: errmsg
14  use memorytypemodule, only: memorytype
19  use tablemodule, only: tabletype, table_cr
21 
22  implicit none
23  private
24  public :: mem_allocate
25  public :: mem_checkin
26  public :: mem_reallocate
27  public :: mem_setptr
28  public :: mem_copyptr
29  public :: mem_reassignptr
30  public :: mem_deallocate
31  public :: mem_write_usage
32  public :: mem_da
33  public :: mem_set_print_option
34  public :: get_from_memorystore
35 
36  public :: get_mem_type
37  public :: get_mem_rank
38  public :: get_mem_elem_size
39  public :: get_mem_shape
40  public :: get_isize
41  public :: copy_dbl1d
42 
43  public :: memorystore
44  public :: mem_print_detailed
45  public :: mem_release
46 
48  type(tabletype), pointer :: memtab => null()
49  integer(I8B) :: nvalues_alogical = 0
50  integer(I8B) :: nvalues_astr = 0
51  integer(I8B) :: nvalues_aint = 0
52  integer(I8B) :: nvalues_adbl = 0
53  integer(I4B) :: iprmem = 0
54 
55  interface mem_allocate
56  module procedure &
59  allocate_str, &
61  allocate_int, &
65  allocate_dbl, &
70  end interface mem_allocate
71 
72  interface mem_checkin
73  module procedure &
75  checkin_int1d, &
76  checkin_int2d, &
77  checkin_dbl1d, &
78  checkin_dbl2d, &
80  end interface mem_checkin
81 
82  interface mem_reallocate
83  module procedure &
91  end interface mem_reallocate
92 
93  interface mem_setptr
94  module procedure &
97  setptr_int, &
98  setptr_int1d, &
99  setptr_int2d, &
100  setptr_int3d, &
101  setptr_dbl, &
102  setptr_dbl1d, &
103  setptr_dbl2d, &
104  setptr_dbl3d, &
105  setptr_str, &
106  setptr_str1d, &
108  end interface mem_setptr
109 
110  interface mem_copyptr
111  module procedure &
113  copyptr_int1d, &
114  copyptr_int2d, &
115  copyptr_dbl1d, &
117  end interface mem_copyptr
118 
119  interface mem_reassignptr
120  module procedure &
121  reassignptr_int, &
127  end interface mem_reassignptr
128 
129  interface mem_deallocate
130  module procedure &
133  deallocate_str, &
136  deallocate_int, &
140  deallocate_dbl, &
144  end interface mem_deallocate
145 
146 contains
147 
148  !> @ brief Get the variable memory type
149  !!
150  !! Returns any of 'LOGICAL', 'INTEGER', 'DOUBLE', 'STRING'.
151  !! returns 'UNKNOWN' when the variable is not found.
152  !<
153  subroutine get_mem_type(name, mem_path, var_type)
154  character(len=*), intent(in) :: name !< variable name
155  character(len=*), intent(in) :: mem_path !< path where the variable is stored
156  character(len=LENMEMTYPE), intent(out) :: var_type !< memory type
157  ! -- local
158  type(memorytype), pointer :: mt
159  logical(LGP) :: found
160  ! -- code
161  mt => null()
162  var_type = 'UNKNOWN'
163  call get_from_memorystore(name, mem_path, mt, found)
164  if (found) then
165  var_type = mt%memtype
166  end if
167  end subroutine get_mem_type
168 
169  !> @ brief Get the variable rank
170  !!
171  !! Returns rank = -1 when not found.
172  !<
173  subroutine get_mem_rank(name, mem_path, rank)
174  character(len=*), intent(in) :: name !< variable name
175  character(len=*), intent(in) :: mem_path !< mem_path
176  integer(I4B), intent(out) :: rank !< rank
177  ! -- local
178  type(memorytype), pointer :: mt => null()
179  logical(LGP) :: found
180  ! -- code
181  !
182  ! -- initialize rank to a value to communicate failure
183  rank = -1
184  !
185  ! -- get the entry from the memory manager
186  call get_from_memorystore(name, mem_path, mt, found)
187  !
188  ! -- set rank
189  if (found) then
190  if (associated(mt%logicalsclr)) rank = 0
191  if (associated(mt%intsclr)) rank = 0
192  if (associated(mt%dblsclr)) rank = 0
193  if (associated(mt%alogical1d)) rank = 1
194  if (associated(mt%aint1d)) rank = 1
195  if (associated(mt%aint2d)) rank = 2
196  if (associated(mt%aint3d)) rank = 3
197  if (associated(mt%adbl1d)) rank = 1
198  if (associated(mt%adbl2d)) rank = 2
199  if (associated(mt%adbl3d)) rank = 3
200  if (associated(mt%strsclr)) rank = 0
201  if (associated(mt%astr1d)) rank = 1
202  if (associated(mt%acharstr1d)) rank = 1
203  end if
204  end subroutine get_mem_rank
205 
206  !> @ brief Get the memory size of a single element of the stored variable
207  !!
208  !! Memory size in bytes, returns size = -1 when not found. This is
209  !< also string length.
210  subroutine get_mem_elem_size(name, mem_path, size)
211  character(len=*), intent(in) :: name !< variable name
212  character(len=*), intent(in) :: mem_path !< path where the variable is stored
213  integer(I4B), intent(out) :: size !< size of the variable in bytes
214  ! -- local
215  type(memorytype), pointer :: mt => null()
216  logical(LGP) :: found
217  ! -- code
218  !
219  ! -- initialize size to a value to communicate failure
220  size = -1
221  !
222  ! -- get the entry from the memory manager
223  call get_from_memorystore(name, mem_path, mt, found)
224  !
225  ! -- set memory size
226  if (found) then
227  size = mt%element_size
228  end if
229  end subroutine get_mem_elem_size
230 
231  !> @ brief Get the variable memory shape
232  !!
233  !! Returns an integer array with the shape (Fortran ordering),
234  !! and set shape(1) = -1 when not found.
235  !<
236  subroutine get_mem_shape(name, mem_path, mem_shape)
237  character(len=*), intent(in) :: name !< variable name
238  character(len=*), intent(in) :: mem_path !< path where the variable is stored
239  integer(I4B), dimension(:), intent(out) :: mem_shape !< shape of the variable
240  ! -- local
241  type(memorytype), pointer :: mt => null()
242  logical(LGP) :: found
243  ! -- code
244  !
245  ! -- get the entry from the memory manager
246  call get_from_memorystore(name, mem_path, mt, found)
247  !
248  ! -- set shape
249  if (found) then
250  if (associated(mt%logicalsclr)) mem_shape = shape(mt%logicalsclr)
251  if (associated(mt%intsclr)) mem_shape = shape(mt%logicalsclr)
252  if (associated(mt%dblsclr)) mem_shape = shape(mt%dblsclr)
253  if (associated(mt%alogical1d)) mem_shape = shape(mt%alogical1d)
254  if (associated(mt%aint1d)) mem_shape = shape(mt%aint1d)
255  if (associated(mt%aint2d)) mem_shape = shape(mt%aint2d)
256  if (associated(mt%aint3d)) mem_shape = shape(mt%aint3d)
257  if (associated(mt%adbl1d)) mem_shape = shape(mt%adbl1d)
258  if (associated(mt%adbl2d)) mem_shape = shape(mt%adbl2d)
259  if (associated(mt%adbl3d)) mem_shape = shape(mt%adbl3d)
260  if (associated(mt%strsclr)) mem_shape = shape(mt%strsclr)
261  if (associated(mt%astr1d)) mem_shape = shape(mt%astr1d)
262  if (associated(mt%acharstr1d)) mem_shape = shape(mt%acharstr1d)
263  ! -- to communicate failure
264  else
265  mem_shape(1) = -1
266  end if
267  end subroutine get_mem_shape
268 
269  !> @ brief Get the number of elements for this variable
270  !!
271  !! Returns with isize = -1 when not found.
272  !! Return 1 for scalars.
273  !<
274  subroutine get_isize(name, mem_path, isize)
275  character(len=*), intent(in) :: name !< variable name
276  character(len=*), intent(in) :: mem_path !< path where the variable is stored
277  integer(I4B), intent(out) :: isize !< number of elements (flattened)
278  ! -- local
279  type(memorytype), pointer :: mt => null()
280  logical(LGP) :: found
281  logical(LGP) :: terminate
282  ! -- code
283  !
284  ! -- initialize isize to a value to communicate failure
285  isize = -1
286  !
287  ! -- don't exit program if variable not found
288  terminate = .false.
289  !
290  ! -- get the entry from the memory manager
291  call get_from_memorystore(name, mem_path, mt, found, terminate)
292  !
293  ! -- set isize
294  if (found) then
295  isize = mt%isize
296  end if
297  end subroutine get_isize
298 
299  !> @ brief Get a memory type entry from the memory list
300  !!
301  !! Default value for @par check is .true. which means that this
302  !! routine will kill the program when the memory entry cannot be found.
303  !<
304  subroutine get_from_memorystore(name, mem_path, mt, found, check)
305  character(len=*), intent(in) :: name !< variable name
306  character(len=*), intent(in) :: mem_path !< path where the variable is stored
307  type(memorytype), pointer, intent(inout) :: mt !< memory type entry
308  logical(LGP), intent(out) :: found !< set to .true. when found
309  logical(LGP), intent(in), optional :: check !< to suppress aborting the program when not found,
310  !! set check = .false.
311  ! -- local
312  logical(LGP) check_opt
313  ! -- code
314  mt => memorystore%get(name, mem_path)
315  found = associated(mt)
316 
317  check_opt = .true.
318  if (present(check)) then
319  check_opt = check
320  end if
321  if (check_opt) then
322  if (.not. found) then
323  errmsg = "Programming error in memory manager. Variable '"// &
324  trim(name)//"' in '"//trim(mem_path)//"' cannot be "// &
325  "assigned because it does not exist in memory manager."
326  call store_error(errmsg, terminate=.true.)
327  end if
328  end if
329  end subroutine get_from_memorystore
330 
331  !> @brief Issue allocation error message and stop program execution
332  !<
333  subroutine allocate_error(varname, mem_path, istat, isize)
334  character(len=*), intent(in) :: varname !< variable name
335  character(len=*), intent(in) :: mem_path !< path where the variable is stored
336  integer(I4B), intent(in) :: istat !< status code
337  integer(I4B), intent(in) :: isize !< size of allocation
338  ! -- local
339  character(len=20) :: csize
340  character(len=20) :: cstat
341  ! -- code
342  !
343  ! -- initialize character variables
344  write (csize, '(i0)') isize
345  write (cstat, '(i0)') istat
346  !
347  ! -- create error message
348  errmsg = "Error trying to allocate memory. Path '"//trim(mem_path)// &
349  "' variable name '"//trim(varname)//"' size '"//trim(csize)// &
350  "'. Error message is '"//trim(adjustl(errmsg))// &
351  "'. Status code is "//trim(cstat)//'.'
352  !
353  ! -- store error and stop program execution
354  call store_error(errmsg, terminate=.true.)
355  end subroutine allocate_error
356 
357  !> @brief Allocate a logical scalar
358  !<
359  subroutine allocate_logical(sclr, name, mem_path)
360  logical(LGP), pointer, intent(inout) :: sclr !< variable for allocation
361  character(len=*), intent(in) :: name !< variable name
362  character(len=*), intent(in) :: mem_path !< path where the variable is stored
363  ! -- local
364  integer(I4B) :: istat
365  type(memorytype), pointer :: mt
366  ! -- code
367  !
368  ! -- check variable name length
369  call mem_check_length(name, lenvarname, "variable")
370  !
371  ! -- allocate the logical scalar
372  allocate (sclr, stat=istat, errmsg=errmsg)
373  if (istat /= 0) then
374  call allocate_error(name, mem_path, istat, 1)
375  end if
376  !
377  ! -- update counter
379  !
380  ! -- allocate memory type
381  allocate (mt)
382  !
383  ! -- set memory type
384  mt%logicalsclr => sclr
385  mt%element_size = lgp
386  mt%isize = 1
387  mt%name = name
388  mt%path = mem_path
389  write (mt%memtype, "(a)") 'LOGICAL'
390  !
391  ! -- add memory type to the memory list
392  call memorystore%add(mt)
393  end subroutine allocate_logical
394 
395  !> @brief Allocate a 1-dimensional logical array
396  !<
397  subroutine allocate_logical1d(alog, nrow, name, mem_path)
398  logical(LGP), dimension(:), pointer, contiguous, intent(inout) :: alog !< variable for allocation
399  integer(I4B), intent(in) :: nrow !< number of rows
400  character(len=*), intent(in) :: name !< variable name
401  character(len=*), intent(in) :: mem_path !< path where variable is stored
402  ! --local
403  type(memorytype), pointer :: mt
404  integer(I4B) :: istat
405  integer(I4B) :: isize
406  ! -- code
407  !
408  ! -- check variable name length
409  call mem_check_length(name, lenvarname, "variable")
410  !
411  ! -- set isize
412  isize = nrow
413  !
414  ! -- allocate logical array
415  allocate (alog(nrow), stat=istat, errmsg=errmsg)
416  if (istat /= 0) then
417  call allocate_error(name, mem_path, istat, isize)
418  end if
419  !
420  ! -- update counter
422  !
423  ! -- allocate memory type
424  allocate (mt)
425  !
426  ! -- set memory type
427  mt%alogical1d => alog
428  mt%element_size = lgp
429  mt%isize = isize
430  mt%name = name
431  mt%path = mem_path
432  write (mt%memtype, "(a,' (',i0,')')") 'LOGICAL', isize
433  !
434  ! -- add memory type to the memory list
435  call memorystore%add(mt)
436  end subroutine allocate_logical1d
437 
438  !> @brief Allocate a character string
439  !<
440  subroutine allocate_str(sclr, ilen, name, mem_path)
441  integer(I4B), intent(in) :: ilen !< string length
442  character(len=ilen), pointer, intent(inout) :: sclr !< variable for allocation
443  character(len=*), intent(in) :: name !< variable name
444  character(len=*), intent(in) :: mem_path !< path where the variable is stored
445  ! -- local
446  integer(I4B) :: istat
447  type(memorytype), pointer :: mt
448  ! -- format
449  ! -- code
450  !
451  ! -- make sure ilen is greater than 0
452  if (ilen < 1) then
453  errmsg = 'Programming error in allocate_str. ILEN must be greater than 0.'
454  call store_error(errmsg, terminate=.true.)
455  end if
456  !
457  ! -- check variable name length
458  call mem_check_length(name, lenvarname, "variable")
459  !
460  ! -- allocate string
461  allocate (character(len=ilen) :: sclr, stat=istat, errmsg=errmsg)
462  if (istat /= 0) then
463  call allocate_error(name, mem_path, istat, 1)
464  end if
465  !
466  ! -- set sclr to a empty string
467  sclr = ' '
468  !
469  ! -- update counter
470  nvalues_astr = nvalues_astr + ilen
471  !
472  ! -- allocate memory type
473  allocate (mt)
474  !
475  ! -- set memory type
476  mt%strsclr => sclr
477  mt%element_size = ilen
478  mt%isize = 1
479  mt%name = name
480  mt%path = mem_path
481  write (mt%memtype, "(a,' LEN=',i0)") 'STRING', ilen
482  !
483  ! -- add defined length string to the memory manager list
484  call memorystore%add(mt)
485  end subroutine allocate_str
486 
487  !> @brief Allocate a 1-dimensional defined length string array
488  !<
489  subroutine allocate_str1d(astr1d, ilen, nrow, name, mem_path)
490  integer(I4B), intent(in) :: ilen !< string length
491  character(len=ilen), dimension(:), &
492  pointer, contiguous, intent(inout) :: astr1d !< variable for allocation
493  integer(I4B), intent(in) :: nrow !< number of strings in array
494  character(len=*), intent(in) :: name !< variable name
495  character(len=*), intent(in) :: mem_path !< path where the variable is stored
496  ! -- local variables
497  type(memorytype), pointer :: mt
498  character(len=ilen) :: string
499  integer(I4B) :: n
500  integer(I4B) :: istat
501  integer(I4B) :: isize
502  ! -- code
503  !
504  ! -- initialize string
505  string = ''
506  !
507  ! -- make sure ilen is greater than 0
508  if (ilen < 1) then
509  errmsg = 'Programming error in allocate_str1d. '// &
510  'ILEN must be greater than 0.'
511  call store_error(errmsg, terminate=.true.)
512  end if
513  !
514  ! -- check variable name length
515  call mem_check_length(name, lenvarname, "variable")
516  !
517  ! -- calculate isize
518  isize = nrow
519  !
520  ! -- allocate defined length string array
521  allocate (character(len=ilen) :: astr1d(nrow), stat=istat, errmsg=errmsg)
522  !
523  ! -- check for error condition
524  if (istat /= 0) then
525  call allocate_error(name, mem_path, istat, isize)
526  end if
527  !
528  ! -- fill deferred length string with empty string
529  do n = 1, nrow
530  astr1d(n) = string
531  end do
532  !
533  ! -- update counter
534  nvalues_astr = nvalues_astr + isize
535  !
536  ! -- allocate memory type
537  allocate (mt)
538  !
539  ! -- set memory type
540  mt%astr1d => astr1d
541  mt%element_size = ilen
542  mt%isize = isize
543  mt%name = name
544  mt%path = mem_path
545  write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow
546  !
547  ! -- add deferred length character array to the memory manager list
548  call memorystore%add(mt)
549  end subroutine allocate_str1d
550 
551  !> @brief Allocate a 1-dimensional array of deferred-length CharacterStringType
552  !<
553  subroutine allocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path)
554  type(characterstringtype), dimension(:), &
555  pointer, contiguous, intent(inout) :: acharstr1d !< variable for allocation
556  integer(I4B), intent(in) :: ilen !< string length
557  integer(I4B), intent(in) :: nrow !< number of strings in array
558  character(len=*), intent(in) :: name !< variable name
559  character(len=*), intent(in) :: mem_path !< path where the variable is stored
560  ! -- local variables
561  character(len=ilen) :: string
562  type(memorytype), pointer :: mt
563  integer(I4B) :: n
564  integer(I4B) :: istat
565  integer(I4B) :: isize
566  ! -- code
567  !
568  ! -- initialize string
569  string = ''
570  !
571  ! -- check variable name length
572  call mem_check_length(name, lenvarname, "variable")
573  !
574  ! -- calculate isize
575  isize = nrow
576  !
577  ! -- allocate deferred length string array
578  allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg)
579  !
580  ! -- check for error condition
581  if (istat /= 0) then
582  call allocate_error(name, mem_path, istat, isize)
583  end if
584  !
585  ! -- fill deferred length string with empty string
586  do n = 1, nrow
587  acharstr1d(n) = string
588  end do
589  !
590  ! -- update counter
591  nvalues_astr = nvalues_astr + isize
592  !
593  ! -- allocate memory type
594  allocate (mt)
595  !
596  ! -- set memory type
597  mt%acharstr1d => acharstr1d
598  mt%element_size = ilen
599  mt%isize = isize
600  mt%name = name
601  mt%path = mem_path
602  write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow
603  !
604  ! -- add deferred length character array to the memory manager list
605  call memorystore%add(mt)
606  end subroutine allocate_charstr1d
607 
608  !> @brief Allocate a integer scalar
609  !<
610  subroutine allocate_int(sclr, name, mem_path)
611  integer(I4B), pointer, intent(inout) :: sclr !< variable for allocation
612  character(len=*), intent(in) :: name !< variable name
613  character(len=*), intent(in) :: mem_path !< path where the variable is stored
614  ! -- local
615  type(memorytype), pointer :: mt
616  integer(I4B) :: istat
617  ! -- code
618  !
619  ! -- check variable name length
620  call mem_check_length(name, lenvarname, "variable")
621  !
622  ! -- allocate integer scalar
623  allocate (sclr, stat=istat, errmsg=errmsg)
624  if (istat /= 0) then
625  call allocate_error(name, mem_path, istat, 1)
626  end if
627  !
628  ! -- update counter
630  !
631  ! -- allocate memory type
632  allocate (mt)
633  !
634  ! -- set memory type
635  mt%intsclr => sclr
636  mt%element_size = i4b
637  mt%isize = 1
638  mt%name = name
639  mt%path = mem_path
640  write (mt%memtype, "(a)") 'INTEGER'
641  !
642  ! -- add memory type to the memory list
643  call memorystore%add(mt)
644  end subroutine allocate_int
645 
646  !> @brief Allocate a 1-dimensional integer array
647  !<
648  subroutine allocate_int1d(aint, nrow, name, mem_path)
649  integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< variable for allocation
650  integer(I4B), intent(in) :: nrow !< integer array number of rows
651  character(len=*), intent(in) :: name !< variable name
652  character(len=*), intent(in) :: mem_path !< path where variable is stored
653  ! --local
654  type(memorytype), pointer :: mt
655  integer(I4B) :: istat
656  integer(I4B) :: isize
657  ! -- code
658  !
659  ! -- check variable name length
660  call mem_check_length(name, lenvarname, "variable")
661  !
662  ! -- set isize
663  isize = nrow
664  !
665  ! -- allocate integer array
666  allocate (aint(nrow), stat=istat, errmsg=errmsg)
667  if (istat /= 0) then
668  call allocate_error(name, mem_path, istat, isize)
669  end if
670  !
671  ! -- update counter
672  nvalues_aint = nvalues_aint + isize
673  !
674  ! -- allocate memory type
675  allocate (mt)
676  !
677  ! -- set memory type
678  mt%aint1d => aint
679  mt%element_size = i4b
680  mt%isize = isize
681  mt%name = name
682  mt%path = mem_path
683  write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize
684  !
685  ! -- add memory type to the memory list
686  call memorystore%add(mt)
687  end subroutine allocate_int1d
688 
689  !> @brief Allocate a 2-dimensional integer array
690  !<
691  subroutine allocate_int2d(aint, ncol, nrow, name, mem_path)
692  integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation
693  integer(I4B), intent(in) :: ncol !< number of columns
694  integer(I4B), intent(in) :: nrow !< number of rows
695  character(len=*), intent(in) :: name !< variable name
696  character(len=*), intent(in) :: mem_path !< path where variable is stored
697  ! -- local
698  type(memorytype), pointer :: mt
699  integer(I4B) :: istat
700  integer(I4B) :: isize
701  ! -- code
702  !
703  ! -- check the variable name length
704  call mem_check_length(name, lenvarname, "variable")
705  !
706  ! -- set isize
707  isize = ncol * nrow
708  !
709  ! -- allocate the integer array
710  allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg)
711  if (istat /= 0) then
712  call allocate_error(name, mem_path, istat, isize)
713  end if
714  !
715  ! -- update the counter
716  nvalues_aint = nvalues_aint + isize
717  !
718  ! -- allocate memory type
719  allocate (mt)
720  !
721  ! -- set memory type
722  mt%aint2d => aint
723  mt%element_size = i4b
724  mt%isize = isize
725  mt%name = name
726  mt%path = mem_path
727  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow
728  !
729  ! -- add memory type to the memory list
730  call memorystore%add(mt)
731  end subroutine allocate_int2d
732 
733  !> @brief Allocate a 3-dimensional integer array
734  !<
735  subroutine allocate_int3d(aint, ncol, nrow, nlay, name, mem_path)
736  integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< variable for allocation
737  integer(I4B), intent(in) :: ncol !< number of columns
738  integer(I4B), intent(in) :: nrow !< number of rows
739  integer(I4B), intent(in) :: nlay !< number of layers
740  character(len=*), intent(in) :: name !< variable name
741  character(len=*), intent(in) :: mem_path !< path where variable is stored
742  ! -- local
743  type(memorytype), pointer :: mt
744  integer(I4B) :: istat
745  integer(I4B) :: isize
746  ! -- code
747  !
748  ! -- check variable name length
749  call mem_check_length(name, lenvarname, "variable")
750  !
751  ! -- set isize
752  isize = ncol * nrow * nlay
753  !
754  ! -- allocate integer array
755  allocate (aint(ncol, nrow, nlay), stat=istat, errmsg=errmsg)
756  if (istat /= 0) then
757  call allocate_error(name, mem_path, istat, isize)
758  end if
759  !
760  ! -- update counter
761  nvalues_aint = nvalues_aint + isize
762  !
763  ! -- allocate memory type
764  allocate (mt)
765  !
766  ! -- set memory type
767  mt%aint3d => aint
768  mt%element_size = i4b
769  mt%isize = isize
770  mt%name = name
771  mt%path = mem_path
772  write (mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'INTEGER', ncol, &
773  nrow, nlay
774  !
775  ! -- add memory type to the memory list
776  call memorystore%add(mt)
777  end subroutine allocate_int3d
778 
779  !> @brief Allocate a real scalar
780  !<
781  subroutine allocate_dbl(sclr, name, mem_path)
782  real(DP), pointer, intent(inout) :: sclr !< variable for allocation
783  character(len=*), intent(in) :: name !< variable name
784  character(len=*), intent(in) :: mem_path !< path where variable is stored
785  ! -- local
786  type(memorytype), pointer :: mt
787  integer(I4B) :: istat
788  ! -- code
789  !
790  ! -- check variable name length
791  call mem_check_length(name, lenvarname, "variable")
792  !
793  ! -- allocate real scalar
794  allocate (sclr, stat=istat, errmsg=errmsg)
795  if (istat /= 0) then
796  call allocate_error(name, mem_path, istat, 1)
797  end if
798  !
799  ! -- update counter
801  !
802  ! -- allocate memory type
803  allocate (mt)
804  !
805  ! -- set memory type
806  mt%dblsclr => sclr
807  mt%element_size = dp
808  mt%isize = 1
809  mt%name = name
810  mt%path = mem_path
811  write (mt%memtype, "(a)") 'DOUBLE'
812  !
813  ! -- add memory type to the memory list
814  call memorystore%add(mt)
815  end subroutine allocate_dbl
816 
817  !> @brief Allocate a 1-dimensional real array
818  !<
819  subroutine allocate_dbl1d(adbl, nrow, name, mem_path)
820  real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< variable for allocation
821  integer(I4B), intent(in) :: nrow !< number of rows
822  character(len=*), intent(in) :: name !< variable name
823  character(len=*), intent(in) :: mem_path !< path where variable is stored
824  ! -- local
825  type(memorytype), pointer :: mt
826  integer(I4B) :: istat
827  integer(I4B) :: isize
828  ! -- code
829  !
830  ! -- check the variable name length
831  call mem_check_length(name, lenvarname, "variable")
832  !
833  ! -- set isize
834  isize = nrow
835  !
836  ! -- allocate the real array
837  allocate (adbl(nrow), stat=istat, errmsg=errmsg)
838  if (istat /= 0) then
839  call allocate_error(name, mem_path, istat, isize)
840  end if
841  !
842  ! -- update counter
843  nvalues_adbl = nvalues_adbl + isize
844  !
845  ! -- allocate memory type
846  allocate (mt)
847  !
848  ! -- set memory type
849  mt%adbl1d => adbl
850  mt%element_size = dp
851  mt%isize = isize
852  mt%name = name
853  mt%path = mem_path
854  write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize
855  !
856  ! -- add memory type to the memory list
857  call memorystore%add(mt)
858  end subroutine allocate_dbl1d
859 
860  !> @brief Allocate a 2-dimensional real array
861  !<
862  subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path)
863  real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation
864  integer(I4B), intent(in) :: ncol !< number of columns
865  integer(I4B), intent(in) :: nrow !< number of rows
866  character(len=*), intent(in) :: name !< variable name
867  character(len=*), intent(in) :: mem_path !< path where variable is stored
868  ! -- local
869  type(memorytype), pointer :: mt
870  integer(I4B) :: istat
871  integer(I4B) :: isize
872  ! -- code
873  !
874  ! -- check the variable name length
875  call mem_check_length(name, lenvarname, "variable")
876  !
877  ! -- set isize
878  isize = ncol * nrow
879  !
880  ! -- allocate the real array
881  allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg)
882  if (istat /= 0) then
883  call allocate_error(name, mem_path, istat, isize)
884  end if
885  !
886  ! -- update counter
887  nvalues_adbl = nvalues_adbl + isize
888  !
889  ! -- allocate memory type
890  allocate (mt)
891  !
892  ! -- set memory type
893  mt%adbl2d => adbl
894  mt%element_size = dp
895  mt%isize = isize
896  mt%name = name
897  mt%path = mem_path
898  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow
899  !
900  ! -- add memory type to the memory list
901  call memorystore%add(mt)
902  end subroutine allocate_dbl2d
903 
904  !> @brief Allocate a 3-dimensional real array
905  !<
906  subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path)
907  real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< variable for allocation
908  integer(I4B), intent(in) :: ncol !< number of columns
909  integer(I4B), intent(in) :: nrow !< number of rows
910  integer(I4B), intent(in) :: nlay !< number of layers
911  character(len=*), intent(in) :: name !< variable name
912  character(len=*), intent(in) :: mem_path !< path where variable is stored
913  ! -- local
914  type(memorytype), pointer :: mt
915  integer(I4B) :: istat
916  integer(I4B) :: isize
917  ! -- code
918  !
919  ! -- check the variable name length
920  call mem_check_length(name, lenvarname, "variable")
921  !
922  ! -- set isize
923  isize = ncol * nrow * nlay
924  !
925  ! -- allocate the real array
926  allocate (adbl(ncol, nrow, nlay), stat=istat, errmsg=errmsg)
927  if (istat /= 0) then
928  call allocate_error(name, mem_path, istat, isize)
929  end if
930  !
931  ! -- update the counter
932  nvalues_adbl = nvalues_adbl + isize
933  !
934  ! -- allocate memory type
935  allocate (mt)
936  !
937  ! -- set memory type
938  mt%adbl3d => adbl
939  mt%element_size = dp
940  mt%isize = isize
941  mt%name = name
942  mt%path = mem_path
943  write (mt%memtype, "(a,' (',i0,',',i0,',',i0,')')") 'DOUBLE', ncol, &
944  nrow, nlay
945  !
946  ! -- add memory type to the memory list
947  call memorystore%add(mt)
948  end subroutine allocate_dbl3d
949 
950  !> @brief Check in an existing 1d logical array with a new address (name + path)
951  !<
952  subroutine checkin_logical1d(alog, name, mem_path, name2, mem_path2)
953  logical(LGP), dimension(:), pointer, contiguous, intent(in) :: alog !< the existing array
954  character(len=*), intent(in) :: name !< new variable name
955  character(len=*), intent(in) :: mem_path !< new path where variable is stored
956  character(len=*), intent(in) :: name2 !< existing variable name
957  character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored
958  ! --local
959  type(memorytype), pointer :: mt
960  integer(I4B) :: isize
961  ! -- code
962  !
963  ! -- check variable name length
964  call mem_check_length(name, lenvarname, "variable")
965  !
966  ! -- set isize
967  isize = size(alog)
968  !
969  ! -- allocate memory type
970  allocate (mt)
971  !
972  ! -- set memory type
973  mt%alogical1d => alog
974  mt%element_size = lgp
975  mt%isize = isize
976  mt%name = name
977  mt%path = mem_path
978  write (mt%memtype, "(a,' (',i0,')')") 'LOGICAL', isize
979  !
980  ! -- set master information
981  mt%master = .false.
982  mt%mastername = name2
983  mt%masterPath = mem_path2
984  !
985  ! -- add memory type to the memory list
986  call memorystore%add(mt)
987  end subroutine checkin_logical1d
988 
989  !> @brief Check in an existing 1d integer array with a new address (name + path)
990  !<
991  subroutine checkin_int1d(aint, name, mem_path, name2, mem_path2)
992  integer(I4B), dimension(:), pointer, contiguous, intent(in) :: aint !< the existing array
993  character(len=*), intent(in) :: name !< new variable name
994  character(len=*), intent(in) :: mem_path !< new path where variable is stored
995  character(len=*), intent(in) :: name2 !< existing variable name
996  character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored
997  ! --local
998  type(memorytype), pointer :: mt
999  integer(I4B) :: isize
1000  ! -- code
1001  !
1002  ! -- check variable name length
1003  call mem_check_length(name, lenvarname, "variable")
1004  !
1005  ! -- set isize
1006  isize = size(aint)
1007  !
1008  ! -- allocate memory type
1009  allocate (mt)
1010  !
1011  ! -- set memory type
1012  mt%aint1d => aint
1013  mt%element_size = i4b
1014  mt%isize = isize
1015  mt%name = name
1016  mt%path = mem_path
1017  write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', isize
1018  !
1019  ! -- set master information
1020  mt%master = .false.
1021  mt%mastername = name2
1022  mt%masterPath = mem_path2
1023  !
1024  ! -- add memory type to the memory list
1025  call memorystore%add(mt)
1026  end subroutine checkin_int1d
1027 
1028  !> @brief Check in an existing 2d integer array with a new address (name + path)
1029  !<
1030  subroutine checkin_int2d(aint2d, name, mem_path, name2, mem_path2)
1031  integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint2d !< the existing 2d array
1032  character(len=*), intent(in) :: name !< new variable name
1033  character(len=*), intent(in) :: mem_path !< new path where variable is stored
1034  character(len=*), intent(in) :: name2 !< existing variable name
1035  character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored
1036  ! -- local
1037  type(memorytype), pointer :: mt
1038  integer(I4B) :: ncol, nrow, isize
1039  ! -- code
1040  !
1041  ! -- check the variable name length
1042  call mem_check_length(name, lenvarname, "variable")
1043  !
1044  ! -- set isize
1045  ncol = size(aint2d, dim=1)
1046  nrow = size(aint2d, dim=2)
1047  isize = ncol * nrow
1048  !
1049  ! -- allocate memory type
1050  allocate (mt)
1051  !
1052  ! -- set memory type
1053  mt%aint2d => aint2d
1054  mt%isize = isize
1055  mt%name = name
1056  mt%path = mem_path
1057  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow
1058  !
1059  ! -- set master information
1060  mt%master = .false.
1061  mt%mastername = name2
1062  mt%masterPath = mem_path2
1063  !
1064  ! -- add memory type to the memory list
1065  call memorystore%add(mt)
1066  end subroutine checkin_int2d
1067 
1068  !> @brief Check in an existing 1d double precision array with a new address (name + path)
1069  !<
1070  subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2)
1071  real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the existing array
1072  character(len=*), intent(in) :: name !< new variable name
1073  character(len=*), intent(in) :: mem_path !< new path where variable is stored
1074  character(len=*), intent(in) :: name2 !< existing variable name
1075  character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored
1076  ! -- local
1077  type(memorytype), pointer :: mt
1078  integer(I4B) :: isize
1079  ! -- code
1080  !
1081  ! -- check the variable name length
1082  call mem_check_length(name, lenvarname, "variable")
1083  !
1084  ! -- set isize
1085  isize = size(adbl)
1086  !
1087  ! -- allocate memory type
1088  allocate (mt)
1089  !
1090  ! -- set memory type
1091  mt%adbl1d => adbl
1092  mt%element_size = dp
1093  mt%isize = isize
1094  mt%name = name
1095  mt%path = mem_path
1096  write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize
1097  !
1098  ! -- set master information
1099  mt%master = .false.
1100  mt%mastername = name2
1101  mt%masterPath = mem_path2
1102  !
1103  ! -- add memory type to the memory list
1104  call memorystore%add(mt)
1105  end subroutine checkin_dbl1d
1106 
1107  !> @brief Check in an existing 2d double precision array with a new address (name + path)
1108  !<
1109  subroutine checkin_dbl2d(adbl2d, name, mem_path, name2, mem_path2)
1110  real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl2d !< the existing 2d array
1111  character(len=*), intent(in) :: name !< new variable name
1112  character(len=*), intent(in) :: mem_path !< new path where variable is stored
1113  character(len=*), intent(in) :: name2 !< existing variable name
1114  character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored
1115  ! -- local
1116  type(memorytype), pointer :: mt
1117  integer(I4B) :: ncol, nrow, isize
1118  ! -- code
1119  !
1120  ! -- check the variable name length
1121  call mem_check_length(name, lenvarname, "variable")
1122  !
1123  ! -- set isize
1124  ncol = size(adbl2d, dim=1)
1125  nrow = size(adbl2d, dim=2)
1126  isize = ncol * nrow
1127  !
1128  ! -- allocate memory type
1129  allocate (mt)
1130  !
1131  ! -- set memory type
1132  mt%adbl2d => adbl2d
1133  mt%isize = isize
1134  mt%name = name
1135  mt%path = mem_path
1136  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow
1137  !
1138  ! -- set master information
1139  mt%master = .false.
1140  mt%mastername = name2
1141  mt%masterPath = mem_path2
1142  !
1143  ! -- add memory type to the memory list
1144  call memorystore%add(mt)
1145  end subroutine checkin_dbl2d
1146 
1147  !> @brief Check in an existing 1d CharacterStringType array with a new address (name + path)
1148  !<
1149  subroutine checkin_charstr1d(acharstr1d, ilen, name, mem_path, name2, mem_path2)
1150  type(characterstringtype), dimension(:), &
1151  pointer, contiguous, intent(inout) :: acharstr1d !< the existing array
1152  integer(I4B), intent(in) :: ilen
1153  character(len=*), intent(in) :: name !< new variable name
1154  character(len=*), intent(in) :: mem_path !< new path where variable is stored
1155  character(len=*), intent(in) :: name2 !< existing variable name
1156  character(len=*), intent(in) :: mem_path2 !< existing path where variable is stored
1157  ! --local
1158  type(memorytype), pointer :: mt
1159  integer(I4B) :: isize
1160  ! -- code
1161  !
1162  ! -- check variable name length
1163  call mem_check_length(name, lenvarname, "variable")
1164  !
1165  ! -- set isize
1166  isize = size(acharstr1d)
1167  !
1168  ! -- allocate memory type
1169  allocate (mt)
1170  !
1171  ! -- set memory type
1172  mt%acharstr1d => acharstr1d
1173  mt%element_size = ilen
1174  mt%isize = isize
1175  mt%name = name
1176  mt%path = mem_path
1177  write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, isize
1178  !
1179  ! -- set master information
1180  mt%master = .false.
1181  mt%mastername = name2
1182  mt%masterPath = mem_path2
1183  !
1184  ! -- add memory type to the memory list
1185  call memorystore%add(mt)
1186  end subroutine checkin_charstr1d
1187 
1188  !> @brief Reallocate a 1-dimensional defined length string array
1189  !<
1190  subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path)
1191  integer(I4B), intent(in) :: ilen !< string length
1192  integer(I4B), intent(in) :: nrow !< number of rows
1193  character(len=ilen), dimension(:), pointer, contiguous, intent(inout) :: astr !< the reallocated string array
1194  character(len=*), intent(in) :: name !< variable name
1195  character(len=*), intent(in) :: mem_path !< path where variable is stored
1196  ! -- local
1197  type(memorytype), pointer :: mt
1198  logical(LGP) :: found
1199  character(len=ilen), dimension(:), allocatable :: astrtemp
1200  integer(I4B) :: istat
1201  integer(I4B) :: isize
1202  integer(I4B) :: isize_old
1203  integer(I4B) :: nrow_old
1204  integer(I4B) :: n
1205  !
1206  ! -- Find and assign mt
1207  call get_from_memorystore(name, mem_path, mt, found)
1208  !
1209  ! -- reallocate astr1d
1210  if (found) then
1211  isize_old = mt%isize
1212  if (isize_old > 0) then
1213  nrow_old = size(astr)
1214  else
1215  nrow_old = 0
1216  end if
1217  !
1218  ! -- calculate isize
1219  isize = nrow
1220  !
1221  ! -- allocate astrtemp
1222  allocate (astrtemp(nrow), stat=istat, errmsg=errmsg)
1223  if (istat /= 0) then
1224  call allocate_error(name, mem_path, istat, isize)
1225  end if
1226  !
1227  ! -- copy existing values
1228  do n = 1, nrow_old
1229  astrtemp(n) = astr(n)
1230  end do
1231  !
1232  ! -- fill new values with missing values
1233  do n = nrow_old + 1, nrow
1234  astrtemp(n) = ''
1235  end do
1236  !
1237  ! -- deallocate mt pointer, repoint, recalculate isize
1238  deallocate (astr)
1239  !
1240  ! -- allocate astr1d
1241  allocate (astr(nrow), stat=istat, errmsg=errmsg)
1242  if (istat /= 0) then
1243  call allocate_error(name, mem_path, istat, isize)
1244  end if
1245  !
1246  ! -- fill the reallocate character array
1247  do n = 1, nrow
1248  astr(n) = astrtemp(n)
1249  end do
1250  !
1251  ! -- deallocate temporary storage
1252  deallocate (astrtemp)
1253  !
1254  ! -- reset memory manager values
1255  mt%astr1d => astr
1256  mt%element_size = ilen
1257  mt%isize = isize
1258  mt%nrealloc = mt%nrealloc + 1
1259  mt%master = .true.
1260  nvalues_astr = nvalues_astr + isize - isize_old
1261  write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow
1262  else
1263  errmsg = "Programming error, variable '"//trim(name)//"' from '"// &
1264  trim(mem_path)//"' is not defined in the memory manager. Use "// &
1265  "mem_allocate instead."
1266  call store_error(errmsg, terminate=.true.)
1267  end if
1268  end subroutine reallocate_str1d
1269 
1270  !> @brief Reallocate a 1-dimensional deferred length string array
1271  !<
1272  subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path)
1273  type(characterstringtype), dimension(:), pointer, contiguous, &
1274  intent(inout) :: acharstr1d !< the reallocated charstring array
1275  integer(I4B), intent(in) :: ilen !< string length
1276  integer(I4B), intent(in) :: nrow !< number of rows
1277  character(len=*), intent(in) :: name !< variable name
1278  character(len=*), intent(in) :: mem_path !< path where variable is stored
1279  ! -- local
1280  type(memorytype), pointer :: mt
1281  logical(LGP) :: found
1282  type(characterstringtype), dimension(:), allocatable :: astrtemp
1283  character(len=ilen) :: string
1284  integer(I4B) :: istat
1285  integer(I4B) :: isize
1286  integer(I4B) :: isize_old
1287  integer(I4B) :: nrow_old
1288  integer(I4B) :: n
1289  !
1290  ! -- Initialize string
1291  string = ''
1292  !
1293  ! -- Find and assign mt
1294  call get_from_memorystore(name, mem_path, mt, found)
1295  !
1296  ! -- reallocate astr1d
1297  if (found) then
1298  isize_old = mt%isize
1299  if (isize_old > 0) then
1300  nrow_old = size(acharstr1d)
1301  else
1302  nrow_old = 0
1303  end if
1304  !
1305  ! -- calculate isize
1306  isize = nrow
1307  !
1308  ! -- allocate astrtemp
1309  allocate (astrtemp(nrow), stat=istat, errmsg=errmsg)
1310  if (istat /= 0) then
1311  call allocate_error(name, mem_path, istat, isize)
1312  end if
1313  !
1314  ! -- copy existing values
1315  do n = 1, nrow_old
1316  astrtemp(n) = acharstr1d(n)
1317  call acharstr1d(n)%destroy()
1318  end do
1319  !
1320  ! -- fill new values with missing values
1321  do n = nrow_old + 1, nrow
1322  astrtemp(n) = string
1323  end do
1324  !
1325  ! -- deallocate mt pointer, repoint, recalculate isize
1326  deallocate (acharstr1d)
1327  !
1328  ! -- allocate astr1d
1329  allocate (acharstr1d(nrow), stat=istat, errmsg=errmsg)
1330  if (istat /= 0) then
1331  call allocate_error(name, mem_path, istat, isize)
1332  end if
1333  !
1334  ! -- fill the reallocated character array
1335  do n = 1, nrow
1336  acharstr1d(n) = astrtemp(n)
1337  call astrtemp(n)%destroy()
1338  end do
1339  !
1340  ! -- deallocate temporary storage
1341  deallocate (astrtemp)
1342  !
1343  ! -- reset memory manager values
1344  mt%acharstr1d => acharstr1d
1345  mt%element_size = ilen
1346  mt%isize = isize
1347  mt%nrealloc = mt%nrealloc + 1
1348  mt%master = .true.
1349  nvalues_astr = nvalues_astr + isize - isize_old
1350  write (mt%memtype, "(a,' LEN=',i0,' (',i0,')')") 'STRING', ilen, nrow
1351  else
1352  errmsg = "Programming error, variable '"//trim(name)//"' from '"// &
1353  trim(mem_path)//"' is not defined in the memory manager. Use "// &
1354  "mem_allocate instead."
1355  call store_error(errmsg, terminate=.true.)
1356  end if
1357  end subroutine reallocate_charstr1d
1358 
1359  !> @brief Reallocate a 1-dimensional logical array
1360  !<
1361  subroutine reallocate_logical1d(alog, nrow, name, mem_path)
1362  logical(LGP), dimension(:), pointer, contiguous, intent(inout) :: alog !< the reallocated logical array
1363  integer(I4B), intent(in) :: nrow !< number of rows
1364  character(len=*), intent(in) :: name !< variable name
1365  character(len=*), intent(in) :: mem_path !< path where variable is stored
1366  ! -- local
1367  type(memorytype), pointer :: mt
1368  logical(LGP) :: found
1369  integer(I4B) :: istat
1370  integer(I4B) :: isize
1371  integer(I4B) :: i
1372  integer(I4B) :: isizeold
1373  integer(I4B) :: ifill
1374  ! -- code
1375  !
1376  ! -- Find and assign mt
1377  call get_from_memorystore(name, mem_path, mt, found)
1378  !
1379  ! -- Allocate aint and then refill
1380  isize = nrow
1381  isizeold = size(mt%alogical1d)
1382  ifill = min(isizeold, isize)
1383  allocate (alog(nrow), stat=istat, errmsg=errmsg)
1384  if (istat /= 0) then
1385  call allocate_error(name, mem_path, istat, isize)
1386  end if
1387  do i = 1, ifill
1388  alog(i) = mt%alogical1d(i)
1389  end do
1390  !
1391  ! -- deallocate mt pointer, repoint, recalculate isize
1392  deallocate (mt%alogical1d)
1393  mt%alogical1d => alog
1394  mt%element_size = lgp
1395  mt%isize = isize
1396  mt%nrealloc = mt%nrealloc + 1
1397  mt%master = .true.
1398  nvalues_alogical = nvalues_alogical + isize - isizeold
1399  end subroutine reallocate_logical1d
1400 
1401  !> @brief Reallocate a 1-dimensional integer array
1402  !<
1403  subroutine reallocate_int1d(aint, nrow, name, mem_path)
1404  integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< the reallocated integer array
1405  integer(I4B), intent(in) :: nrow !< number of rows
1406  character(len=*), intent(in) :: name !< variable name
1407  character(len=*), intent(in) :: mem_path !< path where variable is stored
1408  ! -- local
1409  type(memorytype), pointer :: mt
1410  logical(LGP) :: found
1411  integer(I4B) :: istat
1412  integer(I4B) :: isize
1413  integer(I4B) :: i
1414  integer(I4B) :: isizeold
1415  integer(I4B) :: ifill
1416  ! -- code
1417  !
1418  ! -- Find and assign mt
1419  call get_from_memorystore(name, mem_path, mt, found)
1420  !
1421  ! -- Allocate aint and then refill
1422  isize = nrow
1423  isizeold = size(mt%aint1d)
1424  ifill = min(isizeold, isize)
1425  allocate (aint(nrow), stat=istat, errmsg=errmsg)
1426  if (istat /= 0) then
1427  call allocate_error(name, mem_path, istat, isize)
1428  end if
1429  do i = 1, ifill
1430  aint(i) = mt%aint1d(i)
1431  end do
1432  !
1433  ! -- deallocate mt pointer, repoint, recalculate isize
1434  deallocate (mt%aint1d)
1435  mt%aint1d => aint
1436  mt%element_size = i4b
1437  mt%isize = isize
1438  mt%nrealloc = mt%nrealloc + 1
1439  mt%master = .true.
1440  nvalues_aint = nvalues_aint + isize - isizeold
1441  end subroutine reallocate_int1d
1442 
1443  !> @brief Reallocate a 2-dimensional integer array
1444  !<
1445  subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path)
1446  integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< the reallocated 2d integer array
1447  integer(I4B), intent(in) :: ncol !< number of columns
1448  integer(I4B), intent(in) :: nrow !< number of rows
1449  character(len=*), intent(in) :: name !< variable name
1450  character(len=*), intent(in) :: mem_path !< path where variable is stored
1451  ! -- local
1452  type(memorytype), pointer :: mt
1453  logical(LGP) :: found
1454  integer(I4B) :: istat
1455  integer(I4B), dimension(2) :: ishape
1456  integer(I4B) :: i
1457  integer(I4B) :: j
1458  integer(I4B) :: isize
1459  integer(I4B) :: isizeold
1460  ! -- code
1461  !
1462  ! -- Find and assign mt
1463  call get_from_memorystore(name, mem_path, mt, found)
1464  !
1465  ! -- Allocate aint and then refill
1466  ishape = shape(mt%aint2d)
1467  isize = nrow * ncol
1468  isizeold = ishape(1) * ishape(2)
1469  allocate (aint(ncol, nrow), stat=istat, errmsg=errmsg)
1470  if (istat /= 0) then
1471  call allocate_error(name, mem_path, istat, isize)
1472  end if
1473  do i = 1, ishape(2)
1474  do j = 1, ishape(1)
1475  aint(j, i) = mt%aint2d(j, i)
1476  end do
1477  end do
1478  !
1479  ! -- deallocate mt pointer, repoint, recalculate isize
1480  deallocate (mt%aint2d)
1481  mt%aint2d => aint
1482  mt%element_size = i4b
1483  mt%isize = isize
1484  mt%nrealloc = mt%nrealloc + 1
1485  mt%master = .true.
1486  nvalues_aint = nvalues_aint + isize - isizeold
1487  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow
1488  end subroutine reallocate_int2d
1489 
1490  !> @brief Reallocate a 1-dimensional real array
1491  !<
1492  subroutine reallocate_dbl1d(adbl, nrow, name, mem_path)
1493  real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< the reallocated 1d real array
1494  integer(I4B), intent(in) :: nrow !< number of rows
1495  character(len=*), intent(in) :: name !< variable name
1496  character(len=*), intent(in) :: mem_path !< path where variable is stored
1497  ! -- local
1498  type(memorytype), pointer :: mt
1499  integer(I4B) :: istat
1500  integer(I4B) :: isize
1501  integer(I4B) :: i
1502  integer(I4B) :: isizeold
1503  integer(I4B) :: ifill
1504  logical(LGP) :: found
1505  ! -- code
1506  !
1507  ! -- Find and assign mt
1508  call get_from_memorystore(name, mem_path, mt, found)
1509  !
1510  ! -- Allocate adbl and then refill
1511  isize = nrow
1512  isizeold = size(mt%adbl1d)
1513  ifill = min(isizeold, isize)
1514  allocate (adbl(nrow), stat=istat, errmsg=errmsg)
1515  if (istat /= 0) then
1516  call allocate_error(name, mem_path, istat, isize)
1517  end if
1518  do i = 1, ifill
1519  adbl(i) = mt%adbl1d(i)
1520  end do
1521  !
1522  ! -- deallocate mt pointer, repoint, recalculate isize
1523  deallocate (mt%adbl1d)
1524  mt%adbl1d => adbl
1525  mt%element_size = dp
1526  mt%isize = isize
1527  mt%nrealloc = mt%nrealloc + 1
1528  mt%master = .true.
1529  nvalues_adbl = nvalues_adbl + isize - isizeold
1530  write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', isize
1531  end subroutine reallocate_dbl1d
1532 
1533  !> @brief Reallocate a 2-dimensional real array
1534  !<
1535  subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path)
1536  real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< the reallocated 2d real array
1537  integer(I4B), intent(in) :: ncol !< number of columns
1538  integer(I4B), intent(in) :: nrow !< number of rows
1539  character(len=*), intent(in) :: name !< variable name
1540  character(len=*), intent(in) :: mem_path !< path where variable is stored
1541  ! -- local
1542  type(memorytype), pointer :: mt
1543  logical(LGP) :: found
1544  integer(I4B) :: istat
1545  integer(I4B), dimension(2) :: ishape
1546  integer(I4B) :: i
1547  integer(I4B) :: j
1548  integer(I4B) :: isize
1549  integer(I4B) :: isizeold
1550  ! -- code
1551  !
1552  ! -- Find and assign mt
1553  call get_from_memorystore(name, mem_path, mt, found)
1554  !
1555  ! -- Allocate adbl and then refill
1556  ishape = shape(mt%adbl2d)
1557  isize = nrow * ncol
1558  isizeold = ishape(1) * ishape(2)
1559  allocate (adbl(ncol, nrow), stat=istat, errmsg=errmsg)
1560  if (istat /= 0) then
1561  call allocate_error(name, mem_path, istat, isize)
1562  end if
1563  do i = 1, ishape(2)
1564  do j = 1, ishape(1)
1565  adbl(j, i) = mt%adbl2d(j, i)
1566  end do
1567  end do
1568  !
1569  ! -- deallocate mt pointer, repoint, recalculate isize
1570  deallocate (mt%adbl2d)
1571  mt%adbl2d => adbl
1572  mt%element_size = dp
1573  mt%isize = isize
1574  mt%nrealloc = mt%nrealloc + 1
1575  mt%master = .true.
1576  nvalues_adbl = nvalues_adbl + isize - isizeold
1577  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow
1578  end subroutine reallocate_dbl2d
1579 
1580  !> @brief Set pointer to a logical scalar
1581  !<
1582  subroutine setptr_logical(sclr, name, mem_path)
1583  logical(LGP), pointer, intent(inout) :: sclr !< pointer to logical scalar
1584  character(len=*), intent(in) :: name !< variable name
1585  character(len=*), intent(in) :: mem_path !< path where variable is stored
1586  ! -- local
1587  type(memorytype), pointer :: mt
1588  logical(LGP) :: found
1589  ! -- code
1590  call get_from_memorystore(name, mem_path, mt, found)
1591  sclr => mt%logicalsclr
1592  end subroutine setptr_logical
1593 
1594  !> @brief Set pointer to integer scalar
1595  !<
1596  subroutine setptr_int(sclr, name, mem_path)
1597  integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar
1598  character(len=*), intent(in) :: name !< variable name
1599  character(len=*), intent(in) :: mem_path !< path where variable is stored
1600  ! -- local
1601  type(memorytype), pointer :: mt
1602  logical(LGP) :: found
1603  ! -- code
1604  call get_from_memorystore(name, mem_path, mt, found)
1605  sclr => mt%intsclr
1606  end subroutine setptr_int
1607 
1608  !> @brief Set pointer to 1d logical array
1609  !<
1610  subroutine setptr_logical1d(alog, name, mem_path)
1611  logical(LGP), dimension(:), pointer, contiguous, intent(inout) :: alog !< pointer to 1d logical array
1612  character(len=*), intent(in) :: name !< variable name
1613  character(len=*), intent(in) :: mem_path !< path where variable is stored
1614  ! -- local
1615  type(memorytype), pointer :: mt
1616  logical(LGP) :: found
1617  ! -- code
1618  call get_from_memorystore(name, mem_path, mt, found)
1619  alog => mt%alogical1d
1620  end subroutine setptr_logical1d
1621 
1622  !> @brief Set pointer to 1d integer array
1623  !<
1624  subroutine setptr_int1d(aint, name, mem_path)
1625  integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array
1626  character(len=*), intent(in) :: name !< variable name
1627  character(len=*), intent(in) :: mem_path !< path where variable is stored
1628  ! -- local
1629  type(memorytype), pointer :: mt
1630  logical(LGP) :: found
1631  ! -- code
1632  call get_from_memorystore(name, mem_path, mt, found)
1633  aint => mt%aint1d
1634  end subroutine setptr_int1d
1635 
1636  !> @brief Set pointer to 2d integer array
1637  !<
1638  subroutine setptr_int2d(aint, name, mem_path)
1639  integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array
1640  character(len=*), intent(in) :: name !< variable name
1641  character(len=*), intent(in) :: mem_path !< path where variable is stored
1642  ! -- local
1643  type(memorytype), pointer :: mt
1644  logical(LGP) :: found
1645  ! -- code
1646  call get_from_memorystore(name, mem_path, mt, found)
1647  aint => mt%aint2d
1648  end subroutine setptr_int2d
1649 
1650  !> @brief Set pointer to 3d integer array
1651  !<
1652  subroutine setptr_int3d(aint, name, mem_path)
1653  integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< pointer to 3d integer array
1654  character(len=*), intent(in) :: name !< variable name
1655  character(len=*), intent(in) :: mem_path !< path where variable is stored
1656  ! -- local
1657  type(memorytype), pointer :: mt
1658  logical(LGP) :: found
1659  ! -- code
1660  call get_from_memorystore(name, mem_path, mt, found)
1661  aint => mt%aint3d
1662  end subroutine setptr_int3d
1663 
1664  !> @brief Set pointer to a real scalar
1665  !<
1666  subroutine setptr_dbl(sclr, name, mem_path)
1667  real(DP), pointer, intent(inout) :: sclr !< pointer to a real scalar
1668  character(len=*), intent(in) :: name !< variable name
1669  character(len=*), intent(in) :: mem_path !< path where variable is stored
1670  ! -- local
1671  type(memorytype), pointer :: mt
1672  logical(LGP) :: found
1673  ! -- code
1674  call get_from_memorystore(name, mem_path, mt, found)
1675  sclr => mt%dblsclr
1676  end subroutine setptr_dbl
1677 
1678  !> @brief Set pointer to a 1d real array
1679  !<
1680  subroutine setptr_dbl1d(adbl, name, mem_path)
1681  real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array
1682  character(len=*), intent(in) :: name !< variable name
1683  character(len=*), intent(in) :: mem_path !< path where variable is stored
1684  ! -- local
1685  type(memorytype), pointer :: mt
1686  logical(LGP) :: found
1687  ! -- code
1688  call get_from_memorystore(name, mem_path, mt, found)
1689  adbl => mt%adbl1d
1690  end subroutine setptr_dbl1d
1691 
1692  !> @brief Set pointer to a 2d real array
1693  !<
1694  subroutine setptr_dbl2d(adbl, name, mem_path)
1695  real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array
1696  character(len=*), intent(in) :: name !< variable name
1697  character(len=*), intent(in) :: mem_path !< path where variable is stored
1698  ! -- local
1699  type(memorytype), pointer :: mt
1700  logical(LGP) :: found
1701  ! -- code
1702  call get_from_memorystore(name, mem_path, mt, found)
1703  adbl => mt%adbl2d
1704  end subroutine setptr_dbl2d
1705 
1706  !> @brief Set pointer to a 3d real array
1707  !<
1708  subroutine setptr_dbl3d(adbl, name, mem_path)
1709  real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 3d real array
1710  character(len=*), intent(in) :: name !< variable name
1711  character(len=*), intent(in) :: mem_path !< path where variable is stored
1712  ! -- local
1713  type(memorytype), pointer :: mt
1714  logical(LGP) :: found
1715  ! -- code
1716  call get_from_memorystore(name, mem_path, mt, found)
1717  adbl => mt%adbl3d
1718  end subroutine setptr_dbl3d
1719 
1720  !> @brief Set pointer to a string (scalar)
1721  !<
1722  subroutine setptr_str(asrt, name, mem_path)
1723  character(len=:), pointer :: asrt !< pointer to the character string
1724  character(len=*), intent(in) :: name !< variable name
1725  character(len=*), intent(in) :: mem_path !< path where variable is stored
1726  ! -- local
1727  type(memorytype), pointer :: mt
1728  logical(LGP) :: found
1729  ! -- code
1730  call get_from_memorystore(name, mem_path, mt, found)
1731  asrt => mt%strsclr
1732  end subroutine setptr_str
1733 
1734  !> @brief Set pointer to a fixed-length string array
1735  !<
1736  subroutine setptr_str1d(astr1d, name, mem_path)
1737  character(len=:), dimension(:), &
1738  pointer, contiguous, intent(inout) :: astr1d !< pointer to the string array
1739  character(len=*), intent(in) :: name !< variable name
1740  character(len=*), intent(in) :: mem_path !< path where variable is stored
1741  ! -- local
1742  type(memorytype), pointer :: mt
1743  logical(LGP) :: found
1744  ! -- code
1745  call get_from_memorystore(name, mem_path, mt, found)
1746  select type (item => mt%astr1d)
1747  type is (character(*))
1748  astr1d => item
1749  class default
1750  astr1d => null()
1751  end select
1752  end subroutine setptr_str1d
1753 
1754  !> @brief Set pointer to an array of CharacterStringType
1755  !<
1756  subroutine setptr_charstr1d(acharstr1d, name, mem_path)
1757  type(characterstringtype), dimension(:), pointer, contiguous, &
1758  intent(inout) :: acharstr1d !< the reallocated charstring array
1759  character(len=*), intent(in) :: name !< variable name
1760  character(len=*), intent(in) :: mem_path !< path where variable is stored
1761  ! -- local
1762  type(memorytype), pointer :: mt
1763  logical(LGP) :: found
1764  ! -- code
1765  call get_from_memorystore(name, mem_path, mt, found)
1766  acharstr1d => mt%acharstr1d
1767  end subroutine setptr_charstr1d
1768 
1769  !> @brief Make a copy of a 1-dimensional logical array
1770  !<
1771  subroutine copyptr_logical1d(alog, name, mem_path, mem_path_copy)
1772  logical(LGP), dimension(:), pointer, contiguous, intent(inout) :: alog !< returned copy of 1d logical array
1773  character(len=*), intent(in) :: name !< variable name
1774  character(len=*), intent(in) :: mem_path !< path where variable is stored
1775  character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy will be stored,
1776  !! if passed then the copy is added to the
1777  !! memory manager
1778  ! -- local
1779  type(memorytype), pointer :: mt
1780  logical(LGP) :: found
1781  integer(I4B) :: n
1782  ! -- code
1783  call get_from_memorystore(name, mem_path, mt, found)
1784  alog => null()
1785  ! -- check the copy into the memory manager
1786  if (present(mem_path_copy)) then
1787  call allocate_logical1d(alog, size(mt%alogical1d), mt%name, mem_path_copy)
1788  ! -- create a local copy
1789  else
1790  allocate (alog(size(mt%alogical1d)))
1791  end if
1792  do n = 1, size(mt%alogical1d)
1793  alog(n) = mt%alogical1d(n)
1794  end do
1795  end subroutine copyptr_logical1d
1796 
1797  !> @brief Make a copy of a 1-dimensional integer array
1798  !<
1799  subroutine copyptr_int1d(aint, name, mem_path, mem_path_copy)
1800  integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< returned copy of 1d integer array
1801  character(len=*), intent(in) :: name !< variable name
1802  character(len=*), intent(in) :: mem_path !< path where variable is stored
1803  character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy will be stored,
1804  !! if passed then the copy is added to the
1805  !! memory manager
1806  ! -- local
1807  type(memorytype), pointer :: mt
1808  logical(LGP) :: found
1809  integer(I4B) :: n
1810  ! -- code
1811  call get_from_memorystore(name, mem_path, mt, found)
1812  aint => null()
1813  ! -- check the copy into the memory manager
1814  if (present(mem_path_copy)) then
1815  call allocate_int1d(aint, size(mt%aint1d), mt%name, mem_path_copy)
1816  ! -- create a local copy
1817  else
1818  allocate (aint(size(mt%aint1d)))
1819  end if
1820  do n = 1, size(mt%aint1d)
1821  aint(n) = mt%aint1d(n)
1822  end do
1823  end subroutine copyptr_int1d
1824 
1825  !> @brief Make a copy of a 2-dimensional integer array
1826  !<
1827  subroutine copyptr_int2d(aint, name, mem_path, mem_path_copy)
1828  integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< returned copy of 2d integer array
1829  character(len=*), intent(in) :: name !< variable name
1830  character(len=*), intent(in) :: mem_path !< path where variable is stored
1831  character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy will be stored,
1832  !! if passed then the copy is added to the
1833  !! memory manager
1834  ! -- local
1835  type(memorytype), pointer :: mt
1836  logical(LGP) :: found
1837  integer(I4B) :: i
1838  integer(I4B) :: j
1839  integer(I4B) :: ncol
1840  integer(I4B) :: nrow
1841  ! -- code
1842  call get_from_memorystore(name, mem_path, mt, found)
1843  aint => null()
1844  ncol = size(mt%aint2d, dim=1)
1845  nrow = size(mt%aint2d, dim=2)
1846  ! -- check the copy into the memory manager
1847  if (present(mem_path_copy)) then
1848  call allocate_int2d(aint, ncol, nrow, mt%name, mem_path_copy)
1849  ! -- create a local copy
1850  else
1851  allocate (aint(ncol, nrow))
1852  end if
1853  do i = 1, nrow
1854  do j = 1, ncol
1855  aint(j, i) = mt%aint2d(j, i)
1856  end do
1857  end do
1858  end subroutine copyptr_int2d
1859 
1860  !> @brief Make a copy of a 1-dimensional real array
1861  !<
1862  subroutine copyptr_dbl1d(adbl, name, mem_path, mem_path_copy)
1863  real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< returned copy of 1d real array
1864  character(len=*), intent(in) :: name !< variable name
1865  character(len=*), intent(in) :: mem_path !< path where variable is stored
1866  character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy will be stored,
1867  !! if passed then the copy is added to the
1868  !! memory manager
1869  ! -- local
1870  type(memorytype), pointer :: mt
1871  logical(LGP) :: found
1872  integer(I4B) :: n
1873  ! -- code
1874  call get_from_memorystore(name, mem_path, mt, found)
1875  adbl => null()
1876  ! -- check the copy into the memory manager
1877  if (present(mem_path_copy)) then
1878  call allocate_dbl1d(adbl, size(mt%adbl1d), mt%name, mem_path_copy)
1879  ! -- create a local copy
1880  else
1881  allocate (adbl(size(mt%adbl1d)))
1882  end if
1883  do n = 1, size(mt%adbl1d)
1884  adbl(n) = mt%adbl1d(n)
1885  end do
1886  end subroutine copyptr_dbl1d
1887 
1888  !> @brief Make a copy of a 2-dimensional real array
1889  !<
1890  subroutine copyptr_dbl2d(adbl, name, mem_path, mem_path_copy)
1891  real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< returned copy of 2d real array
1892  character(len=*), intent(in) :: name !< variable name
1893  character(len=*), intent(in) :: mem_path !< path where variable is stored
1894  character(len=*), intent(in), optional :: mem_path_copy !< optional path where the copy will be stored,
1895  !! if passed then the copy is added to the
1896  !! memory manager
1897  ! -- local
1898  type(memorytype), pointer :: mt
1899  logical(LGP) :: found
1900  integer(I4B) :: i
1901  integer(I4B) :: j
1902  integer(I4B) :: ncol
1903  integer(I4B) :: nrow
1904  ! -- code
1905  call get_from_memorystore(name, mem_path, mt, found)
1906  adbl => null()
1907  ncol = size(mt%adbl2d, dim=1)
1908  nrow = size(mt%adbl2d, dim=2)
1909  ! -- check the copy into the memory manager
1910  if (present(mem_path_copy)) then
1911  call allocate_dbl2d(adbl, ncol, nrow, mt%name, mem_path_copy)
1912  ! -- create a local copy
1913  else
1914  allocate (adbl(ncol, nrow))
1915  end if
1916  do i = 1, nrow
1917  do j = 1, ncol
1918  adbl(j, i) = mt%adbl2d(j, i)
1919  end do
1920  end do
1921  end subroutine copyptr_dbl2d
1922 
1923  !> @brief Copy values from a 1-dimensional real array in the memory
1924  !< manager to a passed 1-dimensional real array
1925  subroutine copy_dbl1d(adbl, name, mem_path)
1926  real(dp), dimension(:), intent(inout) :: adbl !< target array
1927  character(len=*), intent(in) :: name !< variable name
1928  character(len=*), intent(in) :: mem_path !< path where variable is stored
1929  ! -- local
1930  type(memorytype), pointer :: mt
1931  logical(LGP) :: found
1932  integer(I4B) :: n
1933  ! -- code
1934  call get_from_memorystore(name, mem_path, mt, found)
1935  do n = 1, size(mt%adbl1d)
1936  adbl(n) = mt%adbl1d(n)
1937  end do
1938  end subroutine copy_dbl1d
1939 
1940  !> @brief Set the pointer for an integer scalar to
1941  !< a target array already stored in the memory manager
1942  subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target)
1943  integer(I4B), pointer, intent(inout) :: sclr !< pointer to integer scalar
1944  character(len=*), intent(in) :: name !< variable name
1945  character(len=*), intent(in) :: mem_path !< path where variable is stored
1946  character(len=*), intent(in) :: name_target !< name of target variable
1947  character(len=*), intent(in) :: mem_path_target !< path where target variable is stored
1948  ! -- local
1949  type(memorytype), pointer :: mt
1950  type(memorytype), pointer :: mt2
1951  logical(LGP) :: found
1952  ! -- code
1953  call get_from_memorystore(name, mem_path, mt, found)
1954  call get_from_memorystore(name_target, mem_path_target, mt2, found)
1955  if (associated(sclr)) then
1957  deallocate (sclr)
1958  end if
1959  sclr => mt2%intsclr
1960  mt%intsclr => sclr
1961  mt%element_size = i4b
1962  mt%isize = 1
1963  write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize
1964  !
1965  ! -- set master information
1966  mt%master = .false.
1967  mt%mastername = name_target
1968  mt%masterPath = mem_path_target
1969  end subroutine reassignptr_int
1970 
1971  !> @brief Set the pointer for a 1-dimensional logical array to
1972  !< a target array already stored in the memory manager
1973  subroutine reassignptr_logical1d(alog, name, mem_path, name_target, &
1974  mem_path_target)
1975  logical(LGP), dimension(:), pointer, contiguous, intent(inout) :: alog !< array pointer
1976  character(len=*), intent(in) :: name !< variable name
1977  character(len=*), intent(in) :: mem_path !< path where variable is stored
1978  character(len=*), intent(in) :: name_target !< name of target variable
1979  character(len=*), intent(in) :: mem_path_target !< path where target variable is stored
1980  ! -- local
1981  type(memorytype), pointer :: mt
1982  type(memorytype), pointer :: mt2
1983  logical(LGP) :: found
1984  ! -- code
1985  call get_from_memorystore(name, mem_path, mt, found)
1986  call get_from_memorystore(name_target, mem_path_target, mt2, found)
1987  if (size(alog) > 0) then
1988  nvalues_alogical = nvalues_alogical - size(alog)
1989  deallocate (alog)
1990  end if
1991  alog => mt2%alogical1d
1992  mt%alogical1d => alog
1993  mt%element_size = lgp
1994  mt%isize = size(alog)
1995  write (mt%memtype, "(a,' (',i0,')')") 'LOGICAL', mt%isize
1996  !
1997  ! -- set master information
1998  mt%master = .false.
1999  mt%mastername = name_target
2000  mt%masterPath = mem_path_target
2001  end subroutine reassignptr_logical1d
2002 
2003  !> @brief Set the pointer for a 1-dimensional integer array to
2004  !< a target array already stored in the memory manager
2005  subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target)
2006  integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< pointer to 1d integer array
2007  character(len=*), intent(in) :: name !< variable name
2008  character(len=*), intent(in) :: mem_path !< path where variable is stored
2009  character(len=*), intent(in) :: name_target !< name of target variable
2010  character(len=*), intent(in) :: mem_path_target !< path where target variable is stored
2011  ! -- local
2012  type(memorytype), pointer :: mt
2013  type(memorytype), pointer :: mt2
2014  logical(LGP) :: found
2015  ! -- code
2016  call get_from_memorystore(name, mem_path, mt, found)
2017  call get_from_memorystore(name_target, mem_path_target, mt2, found)
2018  if (size(aint) > 0) then
2019  nvalues_aint = nvalues_aint - size(aint)
2020  deallocate (aint)
2021  end if
2022  aint => mt2%aint1d
2023  mt%aint1d => aint
2024  mt%element_size = i4b
2025  mt%isize = size(aint)
2026  write (mt%memtype, "(a,' (',i0,')')") 'INTEGER', mt%isize
2027  !
2028  ! -- set master information
2029  mt%master = .false.
2030  mt%mastername = name_target
2031  mt%masterPath = mem_path_target
2032  end subroutine reassignptr_int1d
2033 
2034  !> @brief Set the pointer for a 2-dimensional integer array to
2035  !< a target array already stored in the memory manager
2036  subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target)
2037  integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< pointer to 2d integer array
2038  character(len=*), intent(in) :: name !< variable name
2039  character(len=*), intent(in) :: mem_path !< path where variable is stored
2040  character(len=*), intent(in) :: name_target !< name of target variable
2041  character(len=*), intent(in) :: mem_path_target !< path where target variable is stored
2042  ! -- local
2043  type(memorytype), pointer :: mt
2044  type(memorytype), pointer :: mt2
2045  logical(LGP) :: found
2046  integer(I4B) :: ncol
2047  integer(I4B) :: nrow
2048  ! -- code
2049  call get_from_memorystore(name, mem_path, mt, found)
2050  call get_from_memorystore(name_target, mem_path_target, mt2, found)
2051  if (size(aint) > 0) then
2052  nvalues_aint = nvalues_aint - size(aint)
2053  deallocate (aint)
2054  end if
2055  aint => mt2%aint2d
2056  mt%aint2d => aint
2057  mt%element_size = i4b
2058  mt%isize = size(aint)
2059  ncol = size(aint, dim=1)
2060  nrow = size(aint, dim=2)
2061  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'INTEGER', ncol, nrow
2062  !
2063  ! -- set master information
2064  mt%master = .false.
2065  mt%mastername = name_target
2066  mt%masterPath = mem_path_target
2067  end subroutine reassignptr_int2d
2068 
2069  !> @brief Set the pointer for a 1-dimensional real array to
2070  !< a target array already stored in the memory manager
2071  subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target)
2072  real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< pointer to 1d real array
2073  character(len=*), intent(in) :: name !< variable name
2074  character(len=*), intent(in) :: mem_path !< path where variable is stored
2075  character(len=*), intent(in) :: name_target !< name of target variable
2076  character(len=*), intent(in) :: mem_path_target !< path where target variable is stored
2077  ! -- local
2078  type(memorytype), pointer :: mt
2079  type(memorytype), pointer :: mt2
2080  logical(LGP) :: found
2081  ! -- code
2082  call get_from_memorystore(name, mem_path, mt, found)
2083  call get_from_memorystore(name_target, mem_path_target, mt2, found)
2084  if (size(adbl) > 0) then
2085  nvalues_adbl = nvalues_adbl - size(adbl)
2086  deallocate (adbl)
2087  end if
2088  adbl => mt2%adbl1d
2089  mt%adbl1d => adbl
2090  mt%element_size = dp
2091  mt%isize = size(adbl)
2092  write (mt%memtype, "(a,' (',i0,')')") 'DOUBLE', mt%isize
2093  !
2094  ! -- set master information
2095  mt%master = .false.
2096  mt%mastername = name_target
2097  mt%masterPath = mem_path_target
2098  end subroutine reassignptr_dbl1d
2099 
2100  !> @brief Set the pointer for a 2-dimensional real array to
2101  !< a target array already stored in the memory manager
2102  subroutine reassignptr_dbl2d(adbl, name, mem_path, name_target, mem_path_target)
2103  real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< pointer to 2d real array
2104  character(len=*), intent(in) :: name !< variable name
2105  character(len=*), intent(in) :: mem_path !< path where variable is stored
2106  character(len=*), intent(in) :: name_target !< name of target variable
2107  character(len=*), intent(in) :: mem_path_target !< path where target variable is stored
2108  ! -- local
2109  type(memorytype), pointer :: mt
2110  type(memorytype), pointer :: mt2
2111  logical(LGP) :: found
2112  integer(I4B) :: ncol
2113  integer(I4b) :: nrow
2114  ! -- code
2115  call get_from_memorystore(name, mem_path, mt, found)
2116  call get_from_memorystore(name_target, mem_path_target, mt2, found)
2117  if (size(adbl) > 0) then
2118  nvalues_adbl = nvalues_adbl - size(adbl)
2119  deallocate (adbl)
2120  end if
2121  adbl => mt2%adbl2d
2122  mt%adbl2d => adbl
2123  mt%element_size = dp
2124  mt%isize = size(adbl)
2125  ncol = size(adbl, dim=1)
2126  nrow = size(adbl, dim=2)
2127  write (mt%memtype, "(a,' (',i0,',',i0,')')") 'DOUBLE', ncol, nrow
2128  !
2129  ! -- set master information
2130  mt%master = .false.
2131  mt%mastername = name_target
2132  mt%masterPath = mem_path_target
2133  end subroutine reassignptr_dbl2d
2134 
2135  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2136  !<
2137  subroutine deallocate_str(sclr, name, mem_path)
2138  character(len=*), pointer, intent(inout) :: sclr !< pointer to string
2139  character(len=*), intent(in), optional :: name !< variable name
2140  character(len=*), intent(in), optional :: mem_path !< path where variable is stored
2141  ! -- code
2142  return
2143  end subroutine deallocate_str
2144 
2145  !> @brief Deallocate an array of defined-length character strings
2146  !!
2147  !<
2148  subroutine deallocate_str1d(astr1d, name, mem_path)
2149  character(len=*), dimension(:), pointer, contiguous, intent(inout) :: astr1d !< array of strings
2150  character(len=*), optional, intent(in) :: name !< variable name
2151  character(len=*), optional, intent(in) :: mem_path !< path where variable is stored
2152  ! -- code
2153  return
2154 
2155  end subroutine deallocate_str1d
2156 
2157  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2158  !!
2159  !<
2160  subroutine deallocate_charstr1d(astr1d, name, mem_path)
2161  type(characterstringtype), dimension(:), pointer, contiguous, &
2162  intent(inout) :: astr1d !< array of strings
2163  character(len=*), optional, intent(in) :: name !< variable name
2164  character(len=*), optional, intent(in) :: mem_path !< path where variable is stored
2165  ! -- code
2166  return
2167  end subroutine deallocate_charstr1d
2168 
2169  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2170  !<
2171  subroutine deallocate_logical(sclr)
2172  logical(LGP), pointer, intent(inout) :: sclr !< logical scalar to deallocate
2173  ! -- code
2174  return
2175  end subroutine deallocate_logical
2176 
2177  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2178  !<
2179  subroutine deallocate_int(sclr)
2180  integer(I4B), pointer, intent(inout) :: sclr !< integer variable to deallocate
2181  ! -- code
2182  return
2183  end subroutine deallocate_int
2184 
2185  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2186  !<
2187  subroutine deallocate_dbl(sclr)
2188  real(DP), pointer, intent(inout) :: sclr !< real variable to deallocate
2189  ! -- code
2190  return
2191  end subroutine deallocate_dbl
2192 
2193  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2194  !<
2195  subroutine deallocate_logical1d(alog, name, mem_path)
2196  logical(LGP), dimension(:), pointer, contiguous, intent(inout) :: alog !< 1d logical array to deallocate
2197  character(len=*), optional :: name !< variable name
2198  character(len=*), optional :: mem_path !< path where variable is stored
2199  ! -- code
2200  return
2201  end subroutine deallocate_logical1d
2202 
2203  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2204  !<
2205  subroutine deallocate_int1d(aint, name, mem_path)
2206  integer(I4B), dimension(:), pointer, contiguous, intent(inout) :: aint !< 1d integer array to deallocate
2207  character(len=*), optional :: name !< variable name
2208  character(len=*), optional :: mem_path !< path where variable is stored
2209  ! -- code
2210  return
2211  end subroutine deallocate_int1d
2212 
2213  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2214  !<
2215  subroutine deallocate_int2d(aint, name, mem_path)
2216  integer(I4B), dimension(:, :), pointer, contiguous, intent(inout) :: aint !< 2d integer array to deallocate
2217  character(len=*), optional :: name !< variable name
2218  character(len=*), optional :: mem_path !< path where variable is stored
2219  ! -- code
2220  return
2221  end subroutine deallocate_int2d
2222 
2223  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2224  !<
2225  subroutine deallocate_int3d(aint, name, mem_path)
2226  integer(I4B), dimension(:, :, :), pointer, contiguous, intent(inout) :: aint !< 3d integer array to deallocate
2227  character(len=*), optional :: name !< variable name
2228  character(len=*), optional :: mem_path !< path where variable is stored
2229  ! -- code
2230  return
2231  end subroutine deallocate_int3d
2232 
2233  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2234  !<
2235  subroutine deallocate_dbl1d(adbl, name, mem_path)
2236  real(DP), dimension(:), pointer, contiguous, intent(inout) :: adbl !< 1d real array to deallocate
2237  character(len=*), optional :: name !< variable name
2238  character(len=*), optional :: mem_path !< path where variable is stored
2239  ! -- code
2240  return
2241  end subroutine deallocate_dbl1d
2242 
2243  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2244  !<
2245  subroutine deallocate_dbl2d(adbl, name, mem_path)
2246  real(DP), dimension(:, :), pointer, contiguous, intent(inout) :: adbl !< 2d real array to deallocate
2247  character(len=*), optional :: name !< variable name
2248  character(len=*), optional :: mem_path !< path where variable is stored
2249  ! -- code
2250  return
2251  end subroutine deallocate_dbl2d
2252 
2253  !> @brief DEPRECATED. The memory manager will handle the deallocation of the pointer.
2254  !<
2255  subroutine deallocate_dbl3d(adbl, name, mem_path)
2256  real(DP), dimension(:, :, :), pointer, contiguous, intent(inout) :: adbl !< 3d real array to deallocate
2257  character(len=*), optional :: name !< variable name
2258  character(len=*), optional :: mem_path !< path where variable is stored
2259  ! -- code
2260  return
2261  end subroutine deallocate_dbl3d
2262 
2263  !> @brief Set the memory print option
2264  !<
2265  subroutine mem_set_print_option(iout, keyword, error_msg)
2266  integer(I4B), intent(in) :: iout !< unit number for mfsim.lst
2267  character(len=*), intent(in) :: keyword !< memory print option
2268  character(len=*), intent(inout) :: error_msg !< returned error message if keyword is not valid option
2269  ! -- local
2270  ! -- format
2271  ! -- code
2272  select case (keyword)
2273  case ('NONE')
2274  iprmem = 0
2275  write (iout, '(4x, a)') &
2276  'LIMITED MEMORY INFORMATION WILL BE WRITTEN.'
2277  case ('SUMMARY')
2278  iprmem = 1
2279  write (iout, '(4x, a)') &
2280  'A SUMMARY OF SIMULATION MEMORY INFORMATION WILL BE WRITTEN.'
2281  case ('ALL')
2282  iprmem = 2
2283  write (iout, '(4x, a)') &
2284  'ALL SIMULATION MEMORY INFORMATION WILL BE WRITTEN.'
2285  case default
2286  error_msg = "Unknown memory print option '"//trim(keyword)//"."
2287  end select
2288  end subroutine mem_set_print_option
2289 
2290  !> @brief Create a table if memory_print_option is 'SUMMARY'
2291  !<
2292  subroutine mem_summary_table(iout, nrows, cunits)
2293  integer(I4B), intent(in) :: iout !< unit number for mfsim.lst
2294  integer(I4B), intent(in) :: nrows !< number of table rows
2295  character(len=*), intent(in) :: cunits !< memory units (bytes, kilobytes, megabytes, or gigabytes)
2296  ! -- local
2297  character(len=LINELENGTH) :: title
2298  character(len=LINELENGTH) :: text
2299  integer(I4B) :: nterms
2300  ! -- formats
2301  ! -- code
2302  nterms = 6
2303  !
2304  ! -- set up table title
2305  title = 'SUMMARY INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER, '// &
2306  'IN '//trim(cunits)
2307  !
2308  ! -- set up stage tableobj
2309  call table_cr(memtab, 'MEM SUM', title)
2310  call memtab%table_df(nrows, nterms, iout)
2311  !
2312  ! -- data type
2313  text = 'COMPONENT'
2314  call memtab%initialize_column(text, 20, alignment=tableft)
2315  !
2316  ! -- memory allocated for characters
2317  text = 'CHARACTER'
2318  call memtab%initialize_column(text, 15, alignment=tabcenter)
2319  !
2320  ! -- memory allocated for logical
2321  text = 'LOGICAL'
2322  call memtab%initialize_column(text, 15, alignment=tabcenter)
2323  !
2324  ! -- memory allocated for integers
2325  text = 'INTEGER'
2326  call memtab%initialize_column(text, 15, alignment=tabcenter)
2327  !
2328  ! -- memory allocated for reals
2329  text = 'REAL'
2330  call memtab%initialize_column(text, 15, alignment=tabcenter)
2331  !
2332  ! -- total memory allocated
2333  text = 'TOTAL'
2334  call memtab%initialize_column(text, 15, alignment=tabcenter)
2335  end subroutine mem_summary_table
2336 
2337  !> @brief Create a table if memory_print_option is 'ALL'
2338  !<
2339  subroutine mem_detailed_table(iout, nrows)
2340  integer(I4B), intent(in) :: iout !< unit number for mfsim.lst
2341  integer(I4B), intent(in) :: nrows !< number of table rows
2342  ! -- local
2343  character(len=LINELENGTH) :: title
2344  character(len=LINELENGTH) :: text
2345  integer(I4B) :: nterms
2346  ! -- formats
2347  ! -- code
2348  nterms = 5
2349  !
2350  ! -- set up table title
2351  title = 'DETAILED INFORMATION ON VARIABLES STORED IN THE MEMORY MANAGER'
2352  !
2353  ! -- set up stage tableobj
2354  call table_cr(memtab, 'MEM DET', title)
2355  call memtab%table_df(nrows, nterms, iout)
2356  !
2357  ! -- origin
2358  text = 'ORIGIN'
2359  call memtab%initialize_column(text, lenmempath, alignment=tableft)
2360  !
2361  ! -- variable
2362  text = 'VARIABLE NAME'
2363  call memtab%initialize_column(text, lenvarname, alignment=tableft)
2364  !
2365  ! -- data type
2366  text = 'DATA TYPE'
2367  call memtab%initialize_column(text, 16, alignment=tableft)
2368  !
2369  ! -- size
2370  text = 'NUMBER OF ITEMS'
2371  call memtab%initialize_column(text, 20, alignment=tabright)
2372  !
2373  ! -- is it a pointer
2374  text = 'ASSOCIATED VARIABLE'
2375  call memtab%initialize_column(text, lenmemaddress, alignment=tableft)
2376  end subroutine mem_detailed_table
2377 
2378  !> @brief Write a row for the memory_print_option 'SUMMARY' table
2379  !<
2380  subroutine mem_summary_line(component, rchars, rlog, rint, rreal, bytes)
2381  character(len=*), intent(in) :: component !< character defining the program component (e.g. solution)
2382  real(DP), intent(in) :: rchars !< allocated size of characters (in common units)
2383  real(DP), intent(in) :: rlog !< allocated size of logical (in common units)
2384  real(DP), intent(in) :: rint !< allocated size of integer variables (in common units)
2385  real(DP), intent(in) :: rreal !< allocated size of real variables (in common units)
2386  real(DP), intent(in) :: bytes !< total allocated memory in memory manager (in common units)
2387  ! -- formats
2388  ! -- code
2389  !
2390  ! -- write line
2391  call memtab%add_term(component)
2392  call memtab%add_term(rchars)
2393  call memtab%add_term(rlog)
2394  call memtab%add_term(rint)
2395  call memtab%add_term(rreal)
2396  call memtab%add_term(bytes)
2397  end subroutine mem_summary_line
2398 
2399  !> @brief Determine appropriate memory unit and conversion factor
2400  !<
2401  subroutine mem_units(bytes, fact, cunits)
2402  ! -- dummy
2403  real(DP), intent(in) :: bytes !< total nr. of bytes
2404  real(DP), intent(inout) :: fact !< conversion factor
2405  character(len=*), intent(inout) :: cunits !< string with memory unit
2406  ! -- local
2407  ! -- formats
2408  ! -- code
2409  !
2410  ! -- initialize factor and unit string
2411  cunits = 'UNKNOWN'
2412  fact = done
2413  !
2414  ! -- set factor
2415  if (bytes < dep3) then
2416  fact = done
2417  cunits = 'BYTES'
2418  else if (bytes < dep6) then
2419  fact = dem3
2420  cunits = 'KILOBYTES'
2421  else if (bytes < dep9) then
2422  fact = dem6
2423  cunits = 'MEGABYTES'
2424  else
2425  fact = dem9
2426  cunits = 'GIGABYTES'
2427  end if
2428  end subroutine mem_units
2429 
2430  !> @brief Create and fill a table with the total allocated memory
2431  !< in the memory manager
2432  subroutine mem_summary_total(iout, bytes)
2433  integer(I4B), intent(in) :: iout !< unit number for mfsim.lst
2434  real(DP), intent(in) :: bytes !< total number of bytes allocated in the memory manager
2435  ! -- local
2436  character(len=LINELENGTH) :: title
2437  character(len=LINELENGTH) :: text
2438  character(LEN=10) :: cunits
2439  integer(I4B) :: nterms
2440  integer(I4B) :: nrows
2441  real(DP) :: fact
2442  real(DP) :: smb
2443  ! -- formats
2444  ! -- code
2445  !
2446  ! -- calculate factor and memory units
2447  call mem_units(bytes, fact, cunits)
2448  !
2449  ! -- set table terms
2450  nterms = 2
2451  nrows = 6
2452  !
2453  ! -- set up table title
2454  title = 'MEMORY MANAGER TOTAL STORAGE BY DATA TYPE, IN '//trim(cunits)
2455  !
2456  ! -- set up stage tableobj
2457  call table_cr(memtab, 'MEM TOT', title)
2458  call memtab%table_df(nrows, nterms, iout)
2459  !
2460  ! -- data type
2461  text = 'DATA TYPE'
2462  call memtab%initialize_column(text, 15, alignment=tableft)
2463  !
2464  ! -- number of values
2465  text = 'ALLOCATED MEMORY'
2466  call memtab%initialize_column(text, 15, alignment=tabcenter)
2467  !
2468  ! -- write data
2469  !
2470  ! -- characters
2471  smb = real(nvalues_astr, dp) * fact
2472  call memtab%add_term('Character')
2473  call memtab%add_term(smb)
2474  !
2475  ! -- logicals
2476  smb = real(nvalues_alogical * lgp, dp) * fact
2477  call memtab%add_term('Logical')
2478  call memtab%add_term(smb)
2479  !
2480  ! -- integers
2481  smb = real(nvalues_aint * i4b, dp) * fact
2482  call memtab%add_term('Integer')
2483  call memtab%add_term(smb)
2484  !
2485  ! -- reals
2486  smb = real(nvalues_adbl * dp, dp) * fact
2487  call memtab%add_term('Real')
2488  call memtab%add_term(smb)
2489  !
2490  ! -- total memory usage
2491  call memtab%print_separator()
2492  smb = bytes * fact
2493  call memtab%add_term('Total')
2494  call memtab%add_term(smb)
2495  !
2496  ! -- Virtual memory
2497  smb = calc_virtual_mem() * fact
2498  call memtab%add_term('Virtual')
2499  call memtab%add_term(smb)
2500  !
2501  ! -- deallocate table
2502  call mem_cleanup_table()
2503  end subroutine mem_summary_total
2504 
2505  !> @brief Generic function to clean a memory manager table
2506  !<
2507  subroutine mem_cleanup_table()
2508  ! -- local
2509  ! -- formats
2510  ! -- code
2511  call memtab%table_da()
2512  deallocate (memtab)
2513  nullify (memtab)
2514  end subroutine mem_cleanup_table
2515 
2516  !> @brief Write memory manager memory usage based on the
2517  !! user-specified memory_print_option
2518  !!
2519  !! The total memory usage by data types (int, real, etc.)
2520  !! is written for every simulation.
2521  !<
2522  subroutine mem_write_usage(iout)
2523  integer(I4B), intent(in) :: iout !< unit number for mfsim.lst
2524  ! -- local
2525  class(memorytype), pointer :: mt
2526  character(len=LENMEMADDRESS), allocatable, dimension(:) :: cunique
2527  ! character(len=LENMEMPATH) :: mem_path
2528  character(len=LENMEMPATH) :: context
2529  character(len=LENCOMPONENTNAME) :: component
2530  character(len=LENCOMPONENTNAME) :: subcomponent
2531  character(len=LENMEMADDRESS) :: context_component
2532  character(LEN=10) :: cunits
2533  type(memorycontaineriteratortype), allocatable :: itr
2534  integer(I4B) :: icomp
2535  integer(I4B) :: ilen
2536  integer(I8B) :: nchars
2537  integer(I8B) :: nlog
2538  integer(I8B) :: nint
2539  integer(I8B) :: nreal
2540  real(dp) :: simbytes
2541  real(dp) :: fact
2542  real(dp) :: rchars
2543  real(dp) :: rlog
2544  real(dp) :: rint
2545  real(dp) :: rreal
2546  real(dp) :: bytes
2547  ! -- formats
2548  ! -- code
2549  !
2550  ! -- Calculate simulation memory allocation
2551  simbytes = (nvalues_astr + &
2552  nvalues_alogical * lgp + &
2553  nvalues_aint * i4b + &
2554  nvalues_adbl * dp)
2555  simbytes = real(simbytes, dp)
2556  !
2557  ! -- calculate factor and memory units
2558  call mem_units(simbytes, fact, cunits)
2559  !
2560  ! -- Write summary table for simulation components
2561  if (iprmem == 1) then
2562  !
2563  ! -- Find unique names of simulation components
2564  call mem_unique_origins(cunique)
2565  call mem_summary_table(iout, size(cunique), cunits)
2566  do icomp = 1, size(cunique)
2567  nchars = 0
2568  nlog = 0
2569  nint = 0
2570  nreal = 0
2571  bytes = dzero
2572  ilen = len_trim(cunique(icomp))
2573  itr = memorystore%iterator()
2574  do while (itr%has_next())
2575  call itr%next()
2576  mt => itr%value()
2577  call split_mem_path(mt%path, component, subcomponent)
2578  context = get_mem_path_context(mt%path)
2579  context_component = trim(context)//component
2580  if (cunique(icomp) /= context_component(1:ilen)) cycle
2581  if (.not. mt%master) cycle
2582  if (mt%memtype(1:6) == 'STRING') then
2583  nchars = nchars + mt%isize * mt%element_size
2584  else if (mt%memtype(1:7) == 'LOGICAL') then
2585  nlog = nlog + mt%isize
2586  else if (mt%memtype(1:7) == 'INTEGER') then
2587  nint = nint + mt%isize
2588  else if (mt%memtype(1:6) == 'DOUBLE') then
2589  nreal = nreal + mt%isize
2590  end if
2591  end do
2592  !
2593  ! -- calculate size of each data type in bytes
2594  rchars = real(nchars, dp) * fact
2595  rlog = real(nlog * lgp, dp) * fact
2596  rint = real(nint * i4b, dp) * fact
2597  rreal = real(nreal * dp, dp) * fact
2598  !
2599  ! -- calculate total storage in bytes
2600  bytes = rchars + rlog + rint + rreal
2601  !
2602  ! -- write data
2603  call mem_summary_line(cunique(icomp), rchars, rlog, rint, rreal, bytes)
2604  end do
2605  call mem_cleanup_table()
2606  end if
2607  !
2608  ! -- Write table with all variables for iprmem == 2
2609  if (iprmem == 2) then
2610  call mem_print_detailed(iout)
2611  end if
2612  !
2613  ! -- Write total memory allocation
2614  call mem_summary_total(iout, simbytes)
2615  end subroutine mem_write_usage
2616 
2617  subroutine mem_print_detailed(iout)
2618  integer(I4B) :: iout
2619  ! local
2620  class(memorytype), pointer :: mt
2621  type(memorycontaineriteratortype), allocatable :: itr
2622 
2623  call mem_detailed_table(iout, memorystore%count())
2624  itr = memorystore%iterator()
2625  do while (itr%has_next())
2626  call itr%next()
2627  mt => itr%value()
2628  call mt%table_entry(memtab)
2629  end do
2630  call mem_cleanup_table()
2631 
2632  end subroutine mem_print_detailed
2633 
2634  !> @brief Sum up virtual memory, i.e. memory
2635  !< that is owned by other processes
2636  function calc_virtual_mem() result(vmem_size)
2637  real(dp) :: vmem_size
2638  ! local
2639  type(memorycontaineriteratortype), allocatable :: itr
2640  type(memorytype), pointer :: mt
2641 
2642  vmem_size = dzero
2643  itr = memorystore%iterator()
2644  do while (itr%has_next())
2645  call itr%next()
2646  mt => itr%value()
2647  if (index(mt%path, "__P") == 1) then
2648  vmem_size = mt%element_size * mt%isize + vmem_size
2649  end if
2650  end do
2651 
2652  end function calc_virtual_mem
2653 
2654  !> @brief Release a memory store entry: deallocate data and update counters
2655  !!
2656  !! Deallocates the data held by mt, zeroes mt%isize, and decrements the
2657  !! appropriate nvalues_* counter for master entries. no-op when data has
2658  !! already been released. Primarily intended to support the release of
2659  !! input context memory prior to simulation runtime.
2660  !<
2661  subroutine mem_release(mt)
2662  type(memorytype), pointer, intent(inout) :: mt
2663 
2664  if (.not. mt%mt_associated()) return
2665 
2666  if (mt%master) then
2667  if (mt%memtype(1:6) == 'STRING') then
2668  ! nvalues_astr increments differ: scalar adds element_size (ilen),
2669  ! arrays (str1d, charstr1d) add isize only. For IDM release the
2670  ! variables are arrays, so decrement by isize to match.
2671  if (mt%isize == 1) then
2672  nvalues_astr = nvalues_astr - mt%element_size
2673  else
2674  nvalues_astr = nvalues_astr - mt%isize
2675  end if
2676  else if (mt%memtype(1:7) == 'LOGICAL') then
2677  nvalues_alogical = nvalues_alogical - mt%isize
2678  else if (mt%memtype(1:7) == 'INTEGER') then
2679  nvalues_aint = nvalues_aint - mt%isize
2680  else if (mt%memtype(1:6) == 'DOUBLE') then
2681  nvalues_adbl = nvalues_adbl - mt%isize
2682  end if
2683  end if
2684 
2685  call mt%mt_deallocate()
2686  mt%isize = 0
2687  end subroutine mem_release
2688 
2689  !> @brief Deallocate memory in the memory manager
2690  !<
2691  subroutine mem_da()
2692  ! -- modules
2693  use versionmodule, only: idevelopmode
2694  ! -- local
2695  class(memorytype), pointer :: mt
2696  type(memorycontaineriteratortype), allocatable :: itr
2697  ! -- code
2698  itr = memorystore%iterator()
2699  do while (itr%has_next())
2700  call itr%next()
2701  mt => itr%value()
2702  call mt%mt_deallocate()
2703  if (idevelopmode == 1) call mem_da_check(mt)
2704  deallocate (mt)
2705  end do
2706 
2707  call memorystore%clear()
2708  if (count_errors() > 0) then
2709  call store_error('Could not clear memory list.', terminate=.true.)
2710  end if
2711  end subroutine mem_da
2712 
2713  subroutine mem_da_check(mt)
2714  ! -- modules
2715  use inputoutputmodule, only: upcase
2716  ! -- dummy
2717  class(memorytype), pointer :: mt
2718  ! -- local
2719  character(len=LINELENGTH) :: error_msg
2720  character(len=LENVARNAME) :: ucname
2721  !
2722  ! -- check if memory has been deallocated
2723  if (mt%mt_associated() .and. mt%element_size == -1) then
2724  error_msg = trim(adjustl(mt%path))//' '// &
2725  trim(adjustl(mt%name))//' has invalid element size'
2726  call store_error(trim(error_msg))
2727  end if
2728  !
2729  ! -- check if memory has been deallocated
2730  if (mt%mt_associated() .and. mt%isize > 0) then
2731  error_msg = trim(adjustl(mt%path))//' '// &
2732  trim(adjustl(mt%name))//' not deallocated'
2733  call store_error(trim(error_msg))
2734  end if
2735  !
2736  ! -- check case of varname
2737  ucname = mt%name
2738  call upcase(ucname)
2739  if (mt%name /= ucname) then
2740  error_msg = trim(adjustl(mt%path))//' '// &
2741  trim(adjustl(mt%name))//' not upper case'
2742  call store_error(trim(error_msg))
2743  end if
2744  end subroutine mem_da_check
2745 
2746  !> @brief Create a array with unique first components from all memory paths.
2747  !! Only the first component of the memory path is evaluated.
2748  !<
2749  subroutine mem_unique_origins(cunique)
2750  ! -- modules
2752  ! -- dummy
2753  character(len=LENMEMADDRESS), allocatable, dimension(:), intent(inout) :: &
2754  cunique !< array with unique first components
2755  ! -- local
2756  class(memorytype), pointer :: mt
2757  character(len=LENMEMPATH) :: context
2758  character(len=LENCOMPONENTNAME) :: component
2759  character(len=LENCOMPONENTNAME) :: subcomponent
2760  character(len=LENMEMADDRESS) :: context_component
2761  type(memorycontaineriteratortype), allocatable :: itr
2762  integer(I4B) :: ipa
2763  ! -- code
2764  !
2765  ! -- initialize cunique
2766  allocate (cunique(0))
2767  !
2768  ! -- find unique origins
2769  itr = memorystore%iterator()
2770  do while (itr%has_next())
2771  call itr%next()
2772  mt => itr%value()
2773  call split_mem_path(mt%path, component, subcomponent)
2774  context = get_mem_path_context(mt%path)
2775  context_component = trim(context)//component
2776  ipa = ifind(cunique, context_component)
2777  if (ipa < 1) then
2778  call expandarray(cunique, 1)
2779  cunique(size(cunique)) = context_component
2780  end if
2781  end do
2782  end subroutine mem_unique_origins
2783 
2784 end module memorymanagermodule
This module contains simulation constants.
Definition: Constants.f90:9
integer(i4b), parameter linelength
maximum length of a standard line
Definition: Constants.f90:45
integer(i4b), parameter lencomponentname
maximum length of a component name
Definition: Constants.f90:18
@ tabcenter
centered table column
Definition: Constants.f90:172
@ tabright
right justified table column
Definition: Constants.f90:173
@ tableft
left justified table column
Definition: Constants.f90:171
integer(i4b), parameter lenmemaddress
maximum length of the full memory address, including variable name
Definition: Constants.f90:31
real(dp), parameter dep3
real constant 1000
Definition: Constants.f90:88
@ tabucstring
upper case string table data
Definition: Constants.f90:180
@ tabstring
string table data
Definition: Constants.f90:179
@ tabreal
real table data
Definition: Constants.f90:182
@ tabinteger
integer table data
Definition: Constants.f90:181
real(dp), parameter dep6
real constant 1000000
Definition: Constants.f90:89
integer(i4b), parameter lenmemseparator
maximum length of the memory path separator used, currently a '/'
Definition: Constants.f90:26
real(dp), parameter dep9
real constant 1e9
Definition: Constants.f90:90
integer(i4b), parameter lenvarname
maximum length of a variable name
Definition: Constants.f90:17
integer(i4b), parameter, public lenmemtype
maximum length of a memory manager type
Definition: Constants.f90:62
real(dp), parameter dem3
real constant 1e-3
Definition: Constants.f90:106
real(dp), parameter dem6
real constant 1e-6
Definition: Constants.f90:109
real(dp), parameter dzero
real constant zero
Definition: Constants.f90:65
real(dp), parameter dem9
real constant 1e-9
Definition: Constants.f90:112
integer(i4b), parameter lenmempath
maximum length of the memory path
Definition: Constants.f90:27
real(dp), parameter done
real constant 1
Definition: Constants.f90:76
subroutine, public upcase(word)
Convert to upper case.
This module defines variable data types.
Definition: kind.f90:8
character(len=lenmempath) function get_mem_path_context(mem_path)
Return the context from the memory path.
subroutine mem_check_length(name, max_length, description)
Generic routine to check the length of (parts of) the memory address.
subroutine strip_context_mem_path(mem_path, mem_path_no_context)
Remove the context from the memory path.
subroutine split_mem_path(mem_path, component, subcomponent)
Split the memory path into component(s)
subroutine reallocate_int2d(aint, ncol, nrow, name, mem_path)
Reallocate a 2-dimensional integer array.
subroutine allocate_logical(sclr, name, mem_path)
Allocate a logical scalar.
subroutine allocate_int2d(aint, ncol, nrow, name, mem_path)
Allocate a 2-dimensional integer array.
subroutine mem_summary_line(component, rchars, rlog, rint, rreal, bytes)
Write a row for the memory_print_option 'SUMMARY' table.
subroutine allocate_dbl3d(adbl, ncol, nrow, nlay, name, mem_path)
Allocate a 3-dimensional real array.
integer(i8b) nvalues_adbl
subroutine deallocate_str1d(astr1d, name, mem_path)
Deallocate an array of defined-length character strings.
subroutine deallocate_int(sclr)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine deallocate_logical1d(alog, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
type(tabletype), pointer memtab
subroutine setptr_int3d(aint, name, mem_path)
Set pointer to 3d integer array.
subroutine mem_detailed_table(iout, nrows)
Create a table if memory_print_option is 'ALL'.
subroutine deallocate_charstr1d(astr1d, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine allocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path)
Allocate a 1-dimensional array of deferred-length CharacterStringType.
subroutine reallocate_charstr1d(acharstr1d, ilen, nrow, name, mem_path)
Reallocate a 1-dimensional deferred length string array.
subroutine, public mem_write_usage(iout)
Write memory manager memory usage based on the user-specified memory_print_option.
subroutine reallocate_dbl2d(adbl, ncol, nrow, name, mem_path)
Reallocate a 2-dimensional real array.
integer(i8b) nvalues_aint
subroutine setptr_int(sclr, name, mem_path)
Set pointer to integer scalar.
subroutine checkin_charstr1d(acharstr1d, ilen, name, mem_path, name2, mem_path2)
Check in an existing 1d CharacterStringType array with a new address (name + path)
subroutine mem_cleanup_table()
Generic function to clean a memory manager table.
subroutine copyptr_int1d(aint, name, mem_path, mem_path_copy)
Make a copy of a 1-dimensional integer array.
subroutine deallocate_dbl1d(adbl, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine allocate_str1d(astr1d, ilen, nrow, name, mem_path)
Allocate a 1-dimensional defined length string array.
subroutine allocate_str(sclr, ilen, name, mem_path)
Allocate a character string.
subroutine, public get_mem_type(name, mem_path, var_type)
@ brief Get the variable memory type
subroutine setptr_int2d(aint, name, mem_path)
Set pointer to 2d integer array.
subroutine, public mem_da()
Deallocate memory in the memory manager.
subroutine deallocate_int1d(aint, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
integer(i8b) nvalues_astr
subroutine deallocate_dbl(sclr)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine copyptr_int2d(aint, name, mem_path, mem_path_copy)
Make a copy of a 2-dimensional integer array.
subroutine mem_da_check(mt)
subroutine allocate_dbl(sclr, name, mem_path)
Allocate a real scalar.
real(dp) function calc_virtual_mem()
Sum up virtual memory, i.e. memory.
subroutine copyptr_dbl2d(adbl, name, mem_path, mem_path_copy)
Make a copy of a 2-dimensional real array.
subroutine reassignptr_int2d(aint, name, mem_path, name_target, mem_path_target)
Set the pointer for a 2-dimensional integer array to.
subroutine reallocate_logical1d(alog, nrow, name, mem_path)
Reallocate a 1-dimensional logical array.
subroutine setptr_dbl(sclr, name, mem_path)
Set pointer to a real scalar.
subroutine deallocate_int3d(aint, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine deallocate_int2d(aint, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine reassignptr_dbl1d(adbl, name, mem_path, name_target, mem_path_target)
Set the pointer for a 1-dimensional real array to.
subroutine, public mem_release(mt)
Release a memory store entry: deallocate data and update counters.
subroutine allocate_int3d(aint, ncol, nrow, nlay, name, mem_path)
Allocate a 3-dimensional integer array.
subroutine, public get_mem_shape(name, mem_path, mem_shape)
@ brief Get the variable memory shape
subroutine deallocate_dbl2d(adbl, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine mem_units(bytes, fact, cunits)
Determine appropriate memory unit and conversion factor.
subroutine setptr_int1d(aint, name, mem_path)
Set pointer to 1d integer array.
subroutine setptr_str1d(astr1d, name, mem_path)
Set pointer to a fixed-length string array.
subroutine checkin_int2d(aint2d, name, mem_path, name2, mem_path2)
Check in an existing 2d integer array with a new address (name + path)
type(memorystoretype), public memorystore
subroutine reallocate_dbl1d(adbl, nrow, name, mem_path)
Reallocate a 1-dimensional real array.
subroutine setptr_dbl2d(adbl, name, mem_path)
Set pointer to a 2d real array.
subroutine deallocate_logical(sclr)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine setptr_logical1d(alog, name, mem_path)
Set pointer to 1d logical array.
subroutine checkin_dbl2d(adbl2d, name, mem_path, name2, mem_path2)
Check in an existing 2d double precision array with a new address (name + path)
subroutine deallocate_dbl3d(adbl, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine reallocate_int1d(aint, nrow, name, mem_path)
Reallocate a 1-dimensional integer array.
subroutine checkin_logical1d(alog, name, mem_path, name2, mem_path2)
Check in an existing 1d logical array with a new address (name + path)
subroutine, public get_from_memorystore(name, mem_path, mt, found, check)
@ brief Get a memory type entry from the memory list
subroutine, public mem_print_detailed(iout)
subroutine reallocate_str1d(astr, ilen, nrow, name, mem_path)
Reallocate a 1-dimensional defined length string array.
subroutine copyptr_dbl1d(adbl, name, mem_path, mem_path_copy)
Make a copy of a 1-dimensional real array.
subroutine allocate_logical1d(alog, nrow, name, mem_path)
Allocate a 1-dimensional logical array.
subroutine reassignptr_dbl2d(adbl, name, mem_path, name_target, mem_path_target)
Set the pointer for a 2-dimensional real array to.
subroutine copyptr_logical1d(alog, name, mem_path, mem_path_copy)
Make a copy of a 1-dimensional logical array.
subroutine allocate_int1d(aint, nrow, name, mem_path)
Allocate a 1-dimensional integer array.
subroutine allocate_int(sclr, name, mem_path)
Allocate a integer scalar.
subroutine reassignptr_int1d(aint, name, mem_path, name_target, mem_path_target)
Set the pointer for a 1-dimensional integer array to.
subroutine mem_summary_total(iout, bytes)
Create and fill a table with the total allocated memory.
subroutine, public get_isize(name, mem_path, isize)
@ brief Get the number of elements for this variable
subroutine allocate_dbl2d(adbl, ncol, nrow, name, mem_path)
Allocate a 2-dimensional real array.
subroutine deallocate_str(sclr, name, mem_path)
DEPRECATED. The memory manager will handle the deallocation of the pointer.
subroutine, public get_mem_rank(name, mem_path, rank)
@ brief Get the variable rank
subroutine checkin_dbl1d(adbl, name, mem_path, name2, mem_path2)
Check in an existing 1d double precision array with a new address (name + path)
subroutine checkin_int1d(aint, name, mem_path, name2, mem_path2)
Check in an existing 1d integer array with a new address (name + path)
subroutine reassignptr_logical1d(alog, name, mem_path, name_target, mem_path_target)
Set the pointer for a 1-dimensional logical array to.
subroutine reassignptr_int(sclr, name, mem_path, name_target, mem_path_target)
Set the pointer for an integer scalar to.
subroutine, public copy_dbl1d(adbl, name, mem_path)
Copy values from a 1-dimensional real array in the memory.
subroutine setptr_dbl3d(adbl, name, mem_path)
Set pointer to a 3d real array.
subroutine, public get_mem_elem_size(name, mem_path, size)
@ brief Get the memory size of a single element of the stored variable
subroutine setptr_dbl1d(adbl, name, mem_path)
Set pointer to a 1d real array.
subroutine setptr_str(asrt, name, mem_path)
Set pointer to a string (scalar)
integer(i8b) nvalues_alogical
subroutine setptr_charstr1d(acharstr1d, name, mem_path)
Set pointer to an array of CharacterStringType.
subroutine mem_unique_origins(cunique)
Create a array with unique first components from all memory paths. Only the first component of the me...
subroutine mem_summary_table(iout, nrows, cunits)
Create a table if memory_print_option is 'SUMMARY'.
subroutine setptr_logical(sclr, name, mem_path)
Set pointer to a logical scalar.
subroutine, public mem_set_print_option(iout, keyword, error_msg)
Set the memory print option.
subroutine allocate_dbl1d(adbl, nrow, name, mem_path)
Allocate a 1-dimensional real array.
subroutine allocate_error(varname, mem_path, istat, isize)
Issue allocation error message and stop program execution.
This module contains simulation methods.
Definition: Sim.f90:10
subroutine, public store_error(msg, terminate)
Store an error message.
Definition: Sim.f90:92
integer(i4b) function, public count_errors()
Return number of errors.
Definition: Sim.f90:59
This module contains simulation variables.
Definition: SimVariables.f90:9
character(len=maxcharlen) errmsg
error message string
subroutine, public table_cr(this, name, title)
Definition: Table.f90:87
This module contains version information.
Definition: version.f90:7
integer(i4b), parameter idevelopmode
Definition: version.f90:19
This class is used to store a single deferred-length character string. It was designed to work in an ...
Definition: CharString.f90:23
An iterator used to iterate through a MemoryContainer.