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