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