1#if defined HAVE_CONFIG_H
2#include "config.h"
3#endif
4
5!!@LICENSE
6!
7! ==================================================================
8! Allocation, reallocation, and deallocation utility routines
9! for pointers
10!
11! Written by J.M.Soler. May 2000.
12! Re-organized by A. Garcia, June 2015.
13! ==================================================================
14! SUBROUTINE alloc_default( old, new, restore, &
15!                           copy, shrink, imin, routine )
16!   Sets defaults for allocation
17! INPUT (optional):
18!   type(allocDefaults) restore : default settings to be restored
19!   logical             copy    : Copy old array to new array?
20!   logical             shrink  : Reduce array size?
21!   integer             imin    : First index (typically 1 in Fortan,
22!                                              0 in C)
23!   character(len=*)    routine : Name of calling routine
24! OUTPUT (optional):
25!   type(allocDefaults) old     : default settings before the call
26!   type(allocDefaults) new     : default settings after the call
27! BEHAVIOR:
28!   All these defaults can be superseeded by optional arguments in
29!     each call to re_alloc.
30!   Initial default values: copy    = .true.
31!                           shrink  = .true.
32!                           imin    = 1
33!                           routine = 'unknown'
34!   If restore is present together with any of copy, shrink, imin, or
35!   routine, these are applied AFTER resetting the restore defaults.
36! USAGE:
37!   In order to restore the allocation defaults possibly set by the
38! calling routine, the suggested construction is:
39!   use alloc_module
40!   type(allocDefaults) oldDefaults
41!   call alloc_default( old=oldDefaults, routine=..., &
42!                       copy=..., shrink=... )
43!   call re_alloc(...)
44!   call alloc_default( restore=oldDefaults )
45! Notice that, if the restore call is skipped, the new defaults will
46! stay in effect until a new call to alloc_dafault is made.
47! ==================================================================
48! SUBROUTINE re_alloc( array, [i1min,] i1max,
49!                      [[i2min,] i2max, [[i3min,] i3max]],
50!                      name, routine, copy, shrink )
51! INPUT:
52!   integer       :: i1min        : Lower bound of first dimension
53!                                   If not present, it is fixed by
54!                                   the last call to alloc_default.
55!                                   If present and the rank is 2(3),
56!                                   then i2min(&i3min) must also be
57!                                   present
58!   integer       :: i1max        : Upper bound of first dimension
59!   integer       :: i2min,i2max  : Bounds of second dimension, if
60!                                   applicable
61!   integer       :: i3min,i3max  : Bounds of third dimension, if appl.
62!
63! INPUT (optional):
64!   character*(*) :: name         : Actual array name or a label for it
65!   character*(*) :: routine      : Name of the calling routine
66!                                     or routine section
67!   logical       :: copy         : Save (copy) contents of old array
68!                                   to new array?
69!   logical       :: shrink       : Reallocate if the new array bounds
70!                                   are contained within the old ones?
71!                                   If not present, copy and/or shrink
72!                                      are fixed by the last call to
73!                                      alloc_default.
74! INPUT/OUTPUT:
75!   TYPE, pointer :: array : Array to be allocated or reallocated.
76!                            Implemented types and ranks are:
77!                              integer,    rank 1, 2, 3
78!                              integer*8,  rank 1
79!                              real*4,     rank 1, 2, 3, 4
80!                              real*8,     rank 1, 2, 3, 4
81!                              complex*16, rank 1, 2
82!                              logical,    rank 1, 2, 3
83!                              character(len=*), rank 1
84! BEHAVIOR:
85!   Pointers MUST NOT enter in an undefined state. Before using them
86! for the first time, they must be nullified explicitly. Alternatively,
87! in f95, they can be initialized as null() upon declaration.
88!   If argument array is not associated on input, it is just allocated.
89!   If array is associated and has the same bounds (or smaller bonds
90! and shrink is false) nothing is done. Thus, it is perfectly safe and
91! efficient to call re_alloc repeatedly without deallocating the array.
92! However, subroutine dealloc is provided to eliminate large arrays
93! when they are not needed.
94!   In order to save (copy) the contents of the old array, the new array
95! needs to be allocated before deallocating the old one. Thus, if the
96! contents are not needed, or if reducing memory is a must, calling
97! re_alloc with copy=.false. makes it to deallocate before allocating.
98!   The elements that are not copied (because copy=.false. or because
99! they are outside the bounds of the input array) return with value
100! zero (integer and real), .false. (logical), or blank (character).
101!   If imin>imax for any dimension, the array pointer returns
102! associated to a zero-size array.
103!
104!   Besides allocating or reallocating the array, re_alloc calls
105! the external routine 'alloc_memory_event' with the number
106! of bytes involved in the allocation and a string identifier
107! built from the 'routine' and 'name' arguments: 'routine@name'.
108! Clients of this module can process this information at will.
109!
110!   Error conditions are reported via a callback to the external
111! routine 'alloc_error_report', with a string message and an
112! integer code.
113! Clients of this module can process this information at will.
114!
115! In future, an extra 'stat' argument might be included in the calls
116! to re_alloc and de_alloc for finer control.
117!
118! ==================================================================---
119! SUBROUTINE de_alloc( array, name, routine )
120! INPUT (optional):
121!   character*(*) :: name    : Actual array name or a label for it
122!   character*(*) :: routine : Name of the calling routine
123!                                or routine section
124! INPUT/OUTPUT:
125!   TYPE, pointer :: array : Array be deallocated (same types and
126!                            kinds as in re_alloc).
127! BEHAVIOR:
128!   Besides deallocating the array, re_alloc decreases the count of
129! memory usage previously counted by re_alloc. Thus, dealloc should
130! not be called to deallocate an array not allocated by re_alloc.
131! Equally, arrays allocated or reallocated by re_alloc should be
132! deallocated by dealloc.
133! ==================================================================---
134MODULE alloc
135!
136! This module has no external build dependencies
137! Final executables must resolve the symbols for the two handlers
138!   alloc_memory_event
139!   alloc_error_report
140! with interfaces specified below
141!
142  implicit none
143
144PUBLIC ::             &
145  alloc_default,      &! Sets allocation defaults
146  re_alloc,           &! Allocation/reallocation
147  de_alloc,           &! Deallocation
148  allocDefaults        ! Derived type to hold allocation defaults
149
150PRIVATE      ! Nothing is declared public beyond this point
151
152integer, parameter :: sp = selected_real_kind(5,10)
153integer, parameter :: dp = selected_real_kind(10,100)
154
155! Interfaces to external routines that must be provided
156! by the calling program
157!
158interface
159   ! Error message and integer code
160   ! If 'code' is 0, this is the last call in a series
161   ! (see below for usage)
162   subroutine alloc_error_report(str,code)
163     character(len=*), intent(in) :: str
164     integer, intent(in)          :: code
165   end subroutine alloc_error_report
166   !
167   ! Logger for memory events
168   !
169   subroutine alloc_memory_event(bytes,name)
170     integer, intent(in)          :: bytes
171     character(len=*), intent(in) :: name
172   end subroutine alloc_memory_event
173end interface
174
175  interface de_alloc
176    module procedure &
177      dealloc_i1, dealloc_i2, dealloc_i3,             &
178      dealloc_E1,                                     &
179      dealloc_r1, dealloc_r2, dealloc_r3, dealloc_r4, &
180      dealloc_d1, dealloc_d2, dealloc_d3, dealloc_d4, &
181      dealloc_z1, dealloc_z2,                         &
182      dealloc_l1, dealloc_l2, dealloc_l3,             &
183      dealloc_s1
184  end interface
185
186  interface re_alloc
187    module procedure &
188      realloc_i1, realloc_i2, realloc_i3,             &
189      realloc_E1,                                     &
190      realloc_r1, realloc_r2, realloc_r3, realloc_r4, &
191      realloc_d1, realloc_d2, realloc_d3, realloc_d4, &
192      realloc_z1, realloc_z2,                         &
193      realloc_l1, realloc_l2, realloc_l3,             &
194      realloc_s1
195!    module procedure & ! AG: Dangerous!!!
196!      realloc_i1s, realloc_i2s, realloc_i3s,              &
197!      realloc_r1s, realloc_r2s, realloc_r3s, realloc_r4s, &
198!      realloc_d1s, realloc_d2s, realloc_d3s, realloc_d4s, &
199!      realloc_l1s, realloc_l2s, realloc_l3s
200  end interface
201
202  ! Initial default values
203  character(len=*), parameter :: &
204    DEFAULT_NAME = 'unknown_name'         ! Array name default
205  character(len=*), parameter :: &
206    DEFAULT_ROUTINE = 'unknown_routine'   ! Routine name default
207
208  ! Derived type to hold allocation default options
209  type allocDefaults
210    private
211    logical ::          copy = .true.              ! Copy default
212    logical ::          shrink = .true.            ! Shrink default
213    integer ::          imin = 1                   ! Imin default
214    character(len=32):: routine = DEFAULT_ROUTINE  ! Routine name default
215  end type allocDefaults
216
217  ! Object to hold present allocation default options
218  type(allocDefaults), save :: DEFAULT
219
220  ! Other common variables
221  integer :: IERR
222  logical :: ASSOCIATED_ARRAY, NEEDS_ALLOC, NEEDS_COPY, NEEDS_DEALLOC
223
224CONTAINS
225
226! ==================================================================
227
228SUBROUTINE alloc_default( old, new, restore,          &
229                          routine, copy, shrink, imin )
230implicit none
231type(allocDefaults), optional, intent(out) :: old, new
232type(allocDefaults), optional, intent(in)  :: restore
233character(len=*),    optional, intent(in)  :: routine
234logical,             optional, intent(in)  :: copy, shrink
235integer,             optional, intent(in)  :: imin
236
237if (present(old))     old = DEFAULT
238if (present(restore)) DEFAULT = restore
239if (present(copy))    DEFAULT%copy   = copy
240if (present(shrink))  DEFAULT%shrink = shrink
241if (present(imin))    DEFAULT%imin   = imin
242if (present(routine)) DEFAULT%routine = routine
243if (present(new))     new = DEFAULT
244
245END SUBROUTINE alloc_default
246
247! ==================================================================
248! Integer array reallocs
249! ==================================================================
250
251SUBROUTINE realloc_i1( array, i1min, i1max, &
252                       name, routine, copy, shrink )
253! Arguments
254implicit none
255integer, dimension(:),      pointer    :: array
256integer,                    intent(in) :: i1min
257integer,                    intent(in) :: i1max
258character(len=*), optional, intent(in) :: name
259character(len=*), optional, intent(in) :: routine
260logical,          optional, intent(in) :: copy
261logical,          optional, intent(in) :: shrink
262
263! Internal variables and arrays
264character, parameter           :: type='I'
265integer, parameter             :: rank=1
266integer, dimension(:), pointer :: old_array
267integer, dimension(2,rank)     :: b, c, new_bounds, old_bounds
268
269! Get old array bounds
270ASSOCIATED_ARRAY = associated(array)
271if (ASSOCIATED_ARRAY) then
272  old_array => array          ! Keep pointer to old array
273  old_bounds(1,:) = lbound(old_array)
274  old_bounds(2,:) = ubound(old_array)
275end if
276
277! Copy new requested array bounds
278new_bounds(1,:) = (/ i1min /)
279new_bounds(2,:) = (/ i1max /)
280
281! Find if it is a new allocation or a true reallocation,
282! and if the contents need to be copied (saved)
283! Argument b returns common bounds
284! Options routine also reads common variable ASSOCIATED_ARRAY,
285! and it sets NEEDS_ALLOC, NEEDS_DEALLOC, and NEEDS_COPY
286call options( b, c, old_bounds, new_bounds, copy, shrink )
287! Deallocate old space
288if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
289  call alloc_count( -size(old_array), type, name, routine )
290  deallocate(old_array,stat=IERR)
291end if
292
293! Allocate new space
294if (NEEDS_ALLOC) then
295  allocate( array(b(1,1):b(2,1)), stat=IERR )
296  call alloc_err( IERR, name, routine, new_bounds )
297  call alloc_count( size(array), type, name, routine )
298  array = 0
299end if
300
301! Copy contents and deallocate old space
302if (NEEDS_COPY) then
303  array(c(1,1):c(2,1)) = old_array(c(1,1):c(2,1))
304  call alloc_count( -size(old_array), type, name, routine )
305  deallocate(old_array,stat=IERR)
306  call alloc_err( IERR, name, routine, old_bounds )
307end if
308END SUBROUTINE realloc_i1
309
310! ==================================================================
311SUBROUTINE realloc_i2( array, i1min,i1max, i2min,i2max,       &
312                       name, routine, copy, shrink )
313implicit none
314character, parameter                   :: type='I'
315integer, parameter                     :: rank=2
316integer, dimension(:,:),    pointer    :: array, old_array
317integer,                    intent(in) :: i1min, i1max, i2min, i2max
318character(len=*), optional, intent(in) :: name, routine
319logical,          optional, intent(in) :: copy, shrink
320integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
321ASSOCIATED_ARRAY = associated(array)
322if (ASSOCIATED_ARRAY) then
323  old_array => array
324  old_bounds(1,:) = lbound(old_array)
325  old_bounds(2,:) = ubound(old_array)
326end if
327new_bounds(1,:) = (/ i1min, i2min /)
328new_bounds(2,:) = (/ i1max, i2max /)
329call options( b, c, old_bounds, new_bounds, copy, shrink )
330if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
331  call alloc_count( -size(old_array), type, name, routine )
332  deallocate(old_array,stat=IERR)
333  call alloc_err( IERR, name, routine, old_bounds )
334end if
335if (NEEDS_ALLOC) then
336  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2)), stat=IERR )
337  call alloc_err( IERR, name, routine, new_bounds )
338  call alloc_count( size(array), type, name, routine )
339  array = 0
340end if
341if (NEEDS_COPY) then
342      array(c(1,1):c(2,1),c(1,2):c(2,2)) =  &
343  old_array(c(1,1):c(2,1),c(1,2):c(2,2))
344  call alloc_count( -size(old_array), type, name, routine )
345  deallocate(old_array,stat=IERR)
346  call alloc_err( IERR, name, routine, old_bounds )
347end if
348END SUBROUTINE realloc_i2
349! ==================================================================
350
351SUBROUTINE realloc_i3( array, i1min,i1max, i2min,i2max, i3min,i3max, &
352                       name, routine, copy, shrink )
353implicit none
354character, parameter                   :: type='I'
355integer, parameter                     :: rank=3
356integer, dimension(:,:,:),  pointer    :: array, old_array
357integer,                    intent(in) :: i1min,i1max, i2min,i2max, &
358                                          i3min,i3max
359character(len=*), optional, intent(in) :: name, routine
360logical,          optional, intent(in) :: copy, shrink
361integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
362ASSOCIATED_ARRAY = associated(array)
363if (ASSOCIATED_ARRAY) then
364  old_array => array
365  old_bounds(1,:) = lbound(old_array)
366  old_bounds(2,:) = ubound(old_array)
367end if
368new_bounds(1,:) = (/ i1min, i2min, i3min /)
369new_bounds(2,:) = (/ i1max, i2max, i3max /)
370call options( b, c, old_bounds, new_bounds, copy, shrink )
371if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
372  call alloc_count( -size(old_array), type, name, routine )
373  deallocate(old_array,stat=IERR)
374  call alloc_err( IERR, name, routine, old_bounds )
375end if
376if (NEEDS_ALLOC) then
377  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2),b(1,3):b(2,3)),stat=IERR)
378  call alloc_err( IERR, name, routine, new_bounds )
379  call alloc_count( size(array), type, name, routine )
380  array = 0
381end if
382if (NEEDS_COPY) then
383      array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3)) =  &
384  old_array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3))
385  call alloc_count( -size(old_array), type, name, routine )
386  deallocate(old_array,stat=IERR)
387  call alloc_err( IERR, name, routine, old_bounds )
388end if
389END SUBROUTINE realloc_i3
390! ==================================================================
391SUBROUTINE realloc_E1( array, i1min, i1max, &
392                       name, routine, copy, shrink )
393! Arguments
394  implicit none
395  integer, parameter :: i8b = selected_int_kind(18)
396integer(i8b), dimension(:), pointer    :: array
397integer,                    intent(in) :: i1min
398integer,                    intent(in) :: i1max
399character(len=*), optional, intent(in) :: name
400character(len=*), optional, intent(in) :: routine
401logical,          optional, intent(in) :: copy
402logical,          optional, intent(in) :: shrink
403
404! Internal variables and arrays
405character, parameter                   :: type='I'
406integer, parameter                     :: rank=1
407integer(i8b), dimension(:), pointer    :: old_array
408integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
409
410! Get old array bounds
411ASSOCIATED_ARRAY = associated(array)
412if (ASSOCIATED_ARRAY) then
413  old_array => array          ! Keep pointer to old array
414  old_bounds(1,:) = lbound(old_array)
415  old_bounds(2,:) = ubound(old_array)
416end if
417
418! Copy new requested array bounds
419new_bounds(1,:) = (/ i1min /)
420new_bounds(2,:) = (/ i1max /)
421
422! Find if it is a new allocation or a true reallocation,
423! and if the contents need to be copied (saved)
424! Argument b returns common bounds
425! Options routine also reads common variable ASSOCIATED_ARRAY,
426! and it sets NEEDS_ALLOC, NEEDS_DEALLOC, and NEEDS_COPY
427call options( b, c, old_bounds, new_bounds, copy, shrink )
428
429! Deallocate old space
430if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
431  call alloc_count( -size(old_array), type, name, routine )
432  deallocate(old_array,stat=IERR)
433  call alloc_err( IERR, name, routine, old_bounds )
434end if
435
436! Allocate new space
437if (NEEDS_ALLOC) then
438  allocate( array(b(1,1):b(2,1)), stat=IERR )
439  call alloc_err( IERR, name, routine, new_bounds )
440  call alloc_count( size(array), type, name, routine )
441  array = 0
442end if
443
444! Copy contents and deallocate old space
445if (NEEDS_COPY) then
446  array(c(1,1):c(2,1)) = old_array(c(1,1):c(2,1))
447  call alloc_count( -size(old_array), type, name, routine )
448  deallocate(old_array,stat=IERR)
449  call alloc_err( IERR, name, routine, old_bounds )
450end if
451
452END SUBROUTINE realloc_E1
453
454! ==================================================================
455! Single precision real array reallocs
456! ==================================================================
457SUBROUTINE realloc_r1( array, i1min, i1max,        &
458                       name, routine, copy, shrink )
459implicit none
460character, parameter                   :: type='R'
461integer, parameter                     :: rank=1
462real(SP), dimension(:),     pointer    :: array, old_array
463integer,                    intent(in) :: i1min, i1max
464character(len=*), optional, intent(in) :: name, routine
465logical,          optional, intent(in) :: copy, shrink
466integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
467ASSOCIATED_ARRAY = associated(array)
468if (ASSOCIATED_ARRAY) then
469  old_array => array
470  old_bounds(1,:) = lbound(old_array)
471  old_bounds(2,:) = ubound(old_array)
472end if
473new_bounds(1,:) = (/ i1min /)
474new_bounds(2,:) = (/ i1max /)
475call options( b, c, old_bounds, new_bounds, copy, shrink )
476if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
477  call alloc_count( -size(old_array), type, name, routine )
478  deallocate(old_array,stat=IERR)
479  call alloc_err( IERR, name, routine, old_bounds )
480end if
481if (NEEDS_ALLOC) then
482  allocate( array(b(1,1):b(2,1)), stat=IERR )
483  call alloc_err( IERR, name, routine, new_bounds )
484  call alloc_count( size(array), type, name, routine )
485  array = 0._sp
486end if
487if (NEEDS_COPY) then
488  array(c(1,1):c(2,1)) = old_array(c(1,1):c(2,1))
489  call alloc_count( -size(old_array), type, name, routine )
490  deallocate(old_array,stat=IERR)
491  call alloc_err( IERR, name, routine, old_bounds )
492end if
493END SUBROUTINE realloc_r1
494! ==================================================================
495SUBROUTINE realloc_r2( array, i1min,i1max, i2min,i2max, &
496                       name, routine, copy, shrink )
497implicit none
498character, parameter             :: type='R'
499integer, parameter               :: rank=2
500real(SP), dimension(:,:),   pointer    :: array, old_array
501integer,                    intent(in) :: i1min, i1max, i2min, i2max
502character(len=*), optional, intent(in) :: name, routine
503logical,          optional, intent(in) :: copy, shrink
504integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
505ASSOCIATED_ARRAY = associated(array)
506if (ASSOCIATED_ARRAY) then
507  old_array => array
508  old_bounds(1,:) = lbound(old_array)
509  old_bounds(2,:) = ubound(old_array)
510end if
511new_bounds(1,:) = (/ i1min, i2min /)
512new_bounds(2,:) = (/ i1max, i2max /)
513call options( b, c, old_bounds, new_bounds, copy, shrink )
514if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
515  call alloc_count( -size(old_array), type, name, routine )
516  deallocate(old_array,stat=IERR)
517  call alloc_err( IERR, name, routine, old_bounds )
518end if
519if (NEEDS_ALLOC) then
520  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2)), stat=IERR )
521  call alloc_err( IERR, name, routine, new_bounds )
522  call alloc_count( size(array), type, name, routine )
523  array = 0._sp
524end if
525if (NEEDS_COPY) then
526      array(c(1,1):c(2,1),c(1,2):c(2,2)) =  &
527  old_array(c(1,1):c(2,1),c(1,2):c(2,2))
528  call alloc_count( -size(old_array), type, name, routine )
529  deallocate(old_array,stat=IERR)
530  call alloc_err( IERR, name, routine, old_bounds )
531end if
532END SUBROUTINE realloc_r2
533! ==================================================================
534SUBROUTINE realloc_r3( array, i1min,i1max, i2min,i2max, i3min,i3max, &
535                       name, routine, copy, shrink )
536implicit none
537character, parameter                   :: type='R'
538integer, parameter                     :: rank=3
539real(SP), dimension(:,:,:), pointer    :: array, old_array
540integer,                    intent(in) :: i1min,i1max, i2min,i2max, &
541                                          i3min,i3max
542character(len=*), optional, intent(in) :: name, routine
543logical,          optional, intent(in) :: copy, shrink
544integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
545ASSOCIATED_ARRAY = associated(array)
546if (ASSOCIATED_ARRAY) then
547  old_array => array          ! Keep pointer to old array
548  old_bounds(1,:) = lbound(old_array)
549  old_bounds(2,:) = ubound(old_array)
550end if
551new_bounds(1,:) = (/ i1min, i2min, i3min /)
552new_bounds(2,:) = (/ i1max, i2max, i3max /)
553call options( b, c, old_bounds, new_bounds, copy, shrink )
554if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
555  call alloc_count( -size(old_array), type, name, routine )
556  deallocate(old_array,stat=IERR)
557  call alloc_err( IERR, name, routine, old_bounds )
558end if
559if (NEEDS_ALLOC) then
560  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2),b(1,3):b(2,3)),stat=IERR)
561  call alloc_err( IERR, name, routine, new_bounds )
562  call alloc_count( size(array), type, name, routine )
563  array = 0._sp
564end if
565if (NEEDS_COPY) then
566      array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3)) =  &
567  old_array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3))
568  call alloc_count( -size(old_array), type, name, routine )
569  deallocate(old_array,stat=IERR)
570  call alloc_err( IERR, name, routine, old_bounds )
571end if
572END SUBROUTINE realloc_r3
573! ==================================================================
574SUBROUTINE realloc_r4( array, i1min,i1max, i2min,i2max, &
575                              i3min,i3max, i4min,i4max, &
576                       name, routine, copy, shrink )
577implicit none
578character, parameter                   :: type='R'
579integer, parameter                     :: rank=4
580real(SP), dimension(:,:,:,:), pointer  :: array, old_array
581integer,                    intent(in) :: i1min,i1max, i2min,i2max, &
582                                          i3min,i3max, i4min,i4max
583character(len=*), optional, intent(in) :: name, routine
584logical,          optional, intent(in) :: copy, shrink
585integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
586ASSOCIATED_ARRAY = associated(array)
587if (ASSOCIATED_ARRAY) then
588  old_array => array
589  old_bounds(1,:) = lbound(old_array)
590  old_bounds(2,:) = ubound(old_array)
591end if
592new_bounds(1,:) = (/ i1min, i2min, i3min, i4min /)
593new_bounds(2,:) = (/ i1max, i2max, i3max, i4max /)
594call options( b, c, old_bounds, new_bounds, copy, shrink )
595if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
596  call alloc_count( -size(old_array), type, name, routine )
597  deallocate(old_array,stat=IERR)
598  call alloc_err( IERR, name, routine, old_bounds )
599end if
600if (NEEDS_ALLOC) then
601  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2), &
602                 b(1,3):b(2,3),b(1,4):b(2,4)),stat=IERR)
603  call alloc_err( IERR, name, routine, new_bounds )
604  call alloc_count( size(array), type, name, routine )
605  array = 0._sp
606end if
607if (NEEDS_COPY) then
608      array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3),c(1,4):c(2,4))= &
609  old_array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3),c(1,4):c(2,4))
610  call alloc_count( -size(old_array), type, name, routine )
611  deallocate(old_array,stat=IERR)
612  call alloc_err( IERR, name, routine, old_bounds )
613end if
614END SUBROUTINE realloc_r4
615! ==================================================================
616! Double precision real array reallocs
617! ==================================================================
618SUBROUTINE realloc_d1( array, i1min, i1max,        &
619                       name, routine, copy, shrink )
620implicit none
621character, parameter                   :: type='D'
622integer, parameter                     :: rank=1
623real(DP), dimension(:),     pointer    :: array, old_array
624integer,                    intent(in) :: i1min, i1max
625character(len=*), optional, intent(in) :: name, routine
626logical,          optional, intent(in) :: copy, shrink
627integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
628ASSOCIATED_ARRAY = associated(array)
629if (ASSOCIATED_ARRAY) then
630  old_array => array
631  old_bounds(1,:) = lbound(old_array)
632  old_bounds(2,:) = ubound(old_array)
633end if
634new_bounds(1,:) = (/ i1min /)
635new_bounds(2,:) = (/ i1max /)
636call options( b, c, old_bounds, new_bounds, copy, shrink )
637if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
638  call alloc_count( -size(old_array), type, name, routine )
639  deallocate(old_array,stat=IERR)
640  call alloc_err( IERR, name, routine, old_bounds )
641end if
642if (NEEDS_ALLOC) then
643  allocate( array(b(1,1):b(2,1)), stat=IERR )
644  call alloc_err( IERR, name, routine, new_bounds )
645  call alloc_count( size(array), type, name, routine )
646  array = 0._dp
647end if
648if (NEEDS_COPY) then
649  array(c(1,1):c(2,1)) = old_array(c(1,1):c(2,1))
650  call alloc_count( -size(old_array), type, name, routine )
651  deallocate(old_array,stat=IERR)
652  call alloc_err( IERR, name, routine, old_bounds )
653end if
654END SUBROUTINE realloc_d1
655! ==================================================================
656SUBROUTINE realloc_d2( array, i1min,i1max, i2min,i2max, &
657                       name, routine, copy, shrink )
658implicit none
659character, parameter                   :: type='D'
660integer, parameter                     :: rank=2
661real(DP), dimension(:,:),   pointer    :: array, old_array
662integer,                    intent(in) :: i1min, i1max, i2min, i2max
663character(len=*), optional, intent(in) :: name, routine
664logical,          optional, intent(in) :: copy, shrink
665integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
666integer                                :: i1, i2
667ASSOCIATED_ARRAY = associated(array)
668if (ASSOCIATED_ARRAY) then
669  old_array => array
670  old_bounds(1,:) = lbound(old_array)
671  old_bounds(2,:) = ubound(old_array)
672end if
673new_bounds(1,:) = (/ i1min, i2min /)
674new_bounds(2,:) = (/ i1max, i2max /)
675call options( b, c, old_bounds, new_bounds, copy, shrink )
676if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
677  call alloc_count( -size(old_array), type, name, routine )
678  deallocate(old_array,stat=IERR)
679  call alloc_err( IERR, name, routine, old_bounds )
680end if
681if (NEEDS_ALLOC) then
682  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2)), stat=IERR )
683  call alloc_err( IERR, name, routine, new_bounds )
684  call alloc_count( size(array), type, name, routine )
685  array = 0._dp
686end if
687if (NEEDS_COPY) then
688!      array(c(1,1):c(2,1),c(1,2):c(2,2)) =  &
689!  old_array(c(1,1):c(2,1),c(1,2):c(2,2))
690  do i2 = c(1,2),c(2,2)
691  do i1 = c(1,1),c(2,1)
692    array(i1,i2) = old_array(i1,i2)
693  end do
694  end do
695  call alloc_count( -size(old_array), type, name, routine )
696  deallocate(old_array,stat=IERR)
697  call alloc_err( IERR, name, routine, old_bounds )
698end if
699END SUBROUTINE realloc_d2
700! ==================================================================
701SUBROUTINE realloc_d3( array, i1min,i1max, i2min,i2max, i3min,i3max, &
702                       name, routine, copy, shrink )
703implicit none
704character, parameter                   :: type='D'
705integer, parameter                     :: rank=3
706real(DP), dimension(:,:,:), pointer    :: array, old_array
707integer,                    intent(in) :: i1min,i1max, i2min,i2max, &
708                                          i3min,i3max
709character(len=*), optional, intent(in) :: name, routine
710logical,          optional, intent(in) :: copy, shrink
711integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
712integer                                :: i1, i2, i3
713ASSOCIATED_ARRAY = associated(array)
714if (ASSOCIATED_ARRAY) then
715  old_array => array
716  old_bounds(1,:) = lbound(old_array)
717  old_bounds(2,:) = ubound(old_array)
718end if
719new_bounds(1,:) = (/ i1min, i2min, i3min /)
720new_bounds(2,:) = (/ i1max, i2max, i3max /)
721call options( b, c, old_bounds, new_bounds, copy, shrink )
722if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
723  call alloc_count( -size(old_array), type, name, routine )
724  deallocate(old_array,stat=IERR)
725  call alloc_err( IERR, name, routine, old_bounds )
726end if
727if (NEEDS_ALLOC) then
728  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2),b(1,3):b(2,3)),stat=IERR)
729  call alloc_err( IERR, name, routine, new_bounds )
730  call alloc_count( size(array), type, name, routine )
731  array = 0._dp
732end if
733if (NEEDS_COPY) then
734!      array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3)) =  &
735!  old_array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3))
736  do i3 = c(1,3),c(2,3)
737  do i2 = c(1,2),c(2,2)
738  do i1 = c(1,1),c(2,1)
739    array(i1,i2,i3) = old_array(i1,i2,i3)
740  end do
741  end do
742  end do
743  call alloc_count( -size(old_array), type, name, routine )
744  deallocate(old_array,stat=IERR)
745  call alloc_err( IERR, name, routine, old_bounds )
746end if
747END SUBROUTINE realloc_d3
748! ==================================================================
749SUBROUTINE realloc_d4( array, i1min,i1max, i2min,i2max, &
750                              i3min,i3max, i4min,i4max, &
751                       name, routine, copy, shrink )
752implicit none
753character, parameter                   :: type='D'
754integer, parameter                     :: rank=4
755real(DP), dimension(:,:,:,:), pointer  :: array, old_array
756integer,                    intent(in) :: i1min,i1max, i2min,i2max, &
757                                          i3min,i3max, i4min,i4max
758character(len=*), optional, intent(in) :: name, routine
759logical,          optional, intent(in) :: copy, shrink
760integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
761ASSOCIATED_ARRAY = associated(array)
762if (ASSOCIATED_ARRAY) then
763  old_array => array
764  old_bounds(1,:) = lbound(old_array)
765  old_bounds(2,:) = ubound(old_array)
766end if
767new_bounds(1,:) = (/ i1min, i2min, i3min, i4min /)
768new_bounds(2,:) = (/ i1max, i2max, i3max, i4max /)
769call options( b, c, old_bounds, new_bounds, copy, shrink )
770if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
771  call alloc_count( -size(old_array), type, name, routine )
772  deallocate(old_array,stat=IERR)
773  call alloc_err( IERR, name, routine, old_bounds )
774end if
775if (NEEDS_ALLOC) then
776  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2), &
777                 b(1,3):b(2,3),b(1,4):b(2,4)),stat=IERR)
778  call alloc_err( IERR, name, routine, new_bounds )
779  call alloc_count( size(array), type, name, routine )
780  array = 0._dp
781end if
782if (NEEDS_COPY) then
783      array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3),c(1,4):c(2,4))= &
784  old_array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3),c(1,4):c(2,4))
785  call alloc_count( -size(old_array), type, name, routine )
786  deallocate(old_array,stat=IERR)
787  call alloc_err( IERR, name, routine, old_bounds )
788end if
789END SUBROUTINE realloc_d4
790! ==================================================================
791! Double precision complex array reallocs
792! ==================================================================
793SUBROUTINE realloc_z1( array, i1min, i1max,        &
794                       name, routine, copy, shrink )
795implicit none
796character, parameter                   :: type='D'
797integer, parameter                     :: rank=1
798complex(DP), dimension(:),  pointer    :: array, old_array
799integer,                    intent(in) :: i1min, i1max
800character(len=*), optional, intent(in) :: name, routine
801logical,          optional, intent(in) :: copy, shrink
802integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
803ASSOCIATED_ARRAY = associated(array)
804if (ASSOCIATED_ARRAY) then
805  old_array => array
806  old_bounds(1,:) = lbound(old_array)
807  old_bounds(2,:) = ubound(old_array)
808end if
809new_bounds(1,:) = (/ i1min /)
810new_bounds(2,:) = (/ i1max /)
811call options( b, c, old_bounds, new_bounds, copy, shrink )
812if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
813  call alloc_count( -2*size(old_array), type, name, routine )
814  deallocate(old_array,stat=IERR)
815  call alloc_err( IERR, name, routine, old_bounds )
816end if
817if (NEEDS_ALLOC) then
818  allocate( array(b(1,1):b(2,1)), stat=IERR )
819  call alloc_err( IERR, name, routine, new_bounds )
820  call alloc_count( 2*size(array), type, name, routine )
821  array = 0._dp
822end if
823if (NEEDS_COPY) then
824  array(c(1,1):c(2,1)) = old_array(c(1,1):c(2,1))
825  call alloc_count( -2*size(old_array), type, name, routine )
826  deallocate(old_array,stat=IERR)
827  call alloc_err( IERR, name, routine, old_bounds )
828end if
829END SUBROUTINE realloc_z1
830! ==================================================================
831SUBROUTINE realloc_z2( array, i1min,i1max, i2min,i2max, &
832                       name, routine, copy, shrink )
833implicit none
834character, parameter                   :: type='D'
835integer, parameter                     :: rank=2
836complex(DP), dimension(:,:),  pointer  :: array, old_array
837integer,                    intent(in) :: i1min, i1max, i2min, i2max
838character(len=*), optional, intent(in) :: name, routine
839logical,          optional, intent(in) :: copy, shrink
840integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
841integer                                :: i1, i2
842ASSOCIATED_ARRAY = associated(array)
843if (ASSOCIATED_ARRAY) then
844  old_array => array
845  old_bounds(1,:) = lbound(old_array)
846  old_bounds(2,:) = ubound(old_array)
847end if
848new_bounds(1,:) = (/ i1min, i2min /)
849new_bounds(2,:) = (/ i1max, i2max /)
850call options( b, c, old_bounds, new_bounds, copy, shrink )
851if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
852  call alloc_count( -2*size(old_array), type, name, routine )
853  deallocate(old_array,stat=IERR)
854  call alloc_err( IERR, name, routine, old_bounds )
855end if
856if (NEEDS_ALLOC) then
857  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2)), stat=IERR )
858  call alloc_err( IERR, name, routine, new_bounds )
859  call alloc_count( 2*size(array), type, name, routine )
860  array = 0._dp
861end if
862if (NEEDS_COPY) then
863!      array(c(1,1):c(2,1),c(1,2):c(2,2)) =  &
864!  old_array(c(1,1):c(2,1),c(1,2):c(2,2))
865  do i2 = c(1,2),c(2,2)
866  do i1 = c(1,1),c(2,1)
867    array(i1,i2) = old_array(i1,i2)
868  end do
869  end do
870  call alloc_count( -2*size(old_array), type, name, routine )
871  deallocate(old_array,stat=IERR)
872  call alloc_err( IERR, name, routine, old_bounds )
873end if
874END SUBROUTINE realloc_z2
875! ==================================================================
876! Logical array reallocs
877! ==================================================================
878SUBROUTINE realloc_l1( array, i1min,i1max,  &
879                       name, routine, copy, shrink )
880implicit none
881character, parameter                   :: type='L'
882integer, parameter                     :: rank=1
883logical, dimension(:),      pointer    :: array, old_array
884integer,                    intent(in) :: i1min,i1max
885character(len=*), optional, intent(in) :: name, routine
886logical,          optional, intent(in) :: copy, shrink
887integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
888ASSOCIATED_ARRAY = associated(array)
889if (ASSOCIATED_ARRAY) then
890  old_array => array
891  old_bounds(1,:) = lbound(old_array)
892  old_bounds(2,:) = ubound(old_array)
893end if
894new_bounds(1,:) = (/ i1min /)
895new_bounds(2,:) = (/ i1max /)
896call options( b, c, old_bounds, new_bounds, copy, shrink )
897if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
898  call alloc_count( -size(old_array), type, name, routine )
899  deallocate(old_array,stat=IERR)
900  call alloc_err( IERR, name, routine, old_bounds )
901end if
902if (NEEDS_ALLOC) then
903  allocate( array(b(1,1):b(2,1)), stat=IERR )
904  call alloc_err( IERR, name, routine, new_bounds )
905  call alloc_count( size(array), type, name, routine )
906  array = .false.
907end if
908if (NEEDS_COPY) then
909  array(c(1,1):c(2,1)) = old_array(c(1,1):c(2,1))
910  call alloc_count( -size(old_array), type, name, routine )
911  deallocate(old_array,stat=IERR)
912  call alloc_err( IERR, name, routine, old_bounds )
913end if
914END SUBROUTINE realloc_l1
915! ==================================================================
916SUBROUTINE realloc_l2( array, i1min,i1max, i2min,i2max, &
917                       name, routine, copy, shrink )
918implicit none
919character, parameter                   :: type='L'
920integer, parameter                     :: rank=2
921logical, dimension(:,:),    pointer    :: array, old_array
922integer,                    intent(in) :: i1min,i1max, i2min,i2max
923character(len=*), optional, intent(in) :: name, routine
924logical,          optional, intent(in) :: copy, shrink
925integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
926ASSOCIATED_ARRAY = associated(array)
927if (ASSOCIATED_ARRAY) then
928  old_array => array
929  old_bounds(1,:) = lbound(old_array)
930  old_bounds(2,:) = ubound(old_array)
931end if
932new_bounds(1,:) = (/ i1min, i2min /)
933new_bounds(2,:) = (/ i1max, i2max /)
934call options( b, c, old_bounds, new_bounds, copy, shrink )
935if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
936  call alloc_count( -size(old_array), type, name, routine )
937  deallocate(old_array,stat=IERR)
938  call alloc_err( IERR, name, routine, old_bounds )
939end if
940if (NEEDS_ALLOC) then
941  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2)), stat=IERR )
942  call alloc_err( IERR, name, routine, new_bounds )
943  call alloc_count( size(array), type, name, routine )
944  array = .false.
945end if
946if (NEEDS_COPY) then
947      array(c(1,1):c(2,1),c(1,2):c(2,2)) = &
948  old_array(c(1,1):c(2,1),c(1,2):c(2,2))
949  call alloc_count( -size(old_array), type, name, routine )
950  deallocate(old_array,stat=IERR)
951  call alloc_err( IERR, name, routine, old_bounds )
952end if
953END SUBROUTINE realloc_l2
954! ==================================================================
955SUBROUTINE realloc_l3( array, i1min,i1max, i2min,i2max, i3min,i3max, &
956                       name, routine, copy, shrink )
957implicit none
958character, parameter                   :: type='L'
959integer, parameter                     :: rank=3
960logical, dimension(:,:,:),  pointer    :: array, old_array
961integer,                    intent(in) :: i1min,i1max, i2min,i2max, &
962                                          i3min,i3max
963character(len=*), optional, intent(in) :: name, routine
964logical,          optional, intent(in) :: copy, shrink
965integer, dimension(2,rank)             :: b, c, new_bounds, old_bounds
966ASSOCIATED_ARRAY = associated(array)
967if (ASSOCIATED_ARRAY) then
968  old_array => array
969  old_bounds(1,:) = lbound(old_array)
970  old_bounds(2,:) = ubound(old_array)
971end if
972new_bounds(1,:) = (/ i1min, i2min, i3min /)
973new_bounds(2,:) = (/ i1max, i2max, i3max /)
974call options( b, c, old_bounds, new_bounds, copy, shrink )
975if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
976  call alloc_count( -size(old_array), type, name, routine )
977  deallocate(old_array,stat=IERR)
978  call alloc_err( IERR, name, routine, old_bounds )
979end if
980if (NEEDS_ALLOC) then
981  allocate( array(b(1,1):b(2,1),b(1,2):b(2,2),b(1,3):b(2,3)),stat=IERR)
982  call alloc_err( IERR, name, routine, new_bounds )
983  call alloc_count( size(array), type, name, routine )
984  array = .false.
985end if
986if (NEEDS_COPY) then
987      array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3)) = &
988  old_array(c(1,1):c(2,1),c(1,2):c(2,2),c(1,3):c(2,3))
989  call alloc_count( -size(old_array), type, name, routine )
990  deallocate(old_array,stat=IERR)
991  call alloc_err( IERR, name, routine, old_bounds )
992end if
993END SUBROUTINE realloc_l3
994! ==================================================================
995! Realloc routines with assumed lower bound = 1
996!AG: Extremely dangerous -- do not use.
997! ==================================================================
998SUBROUTINE realloc_i1s( array, i1max, &
999                        name, routine, copy, shrink )
1000! Arguments
1001implicit none
1002integer, dimension(:),      pointer    :: array
1003integer,                    intent(in) :: i1max
1004character(len=*), optional, intent(in) :: name
1005character(len=*), optional, intent(in) :: routine
1006logical,          optional, intent(in) :: copy
1007logical,          optional, intent(in) :: shrink
1008
1009call realloc_i1( array, DEFAULT%imin, i1max, &
1010                 name, routine, copy, shrink )
1011
1012END SUBROUTINE realloc_i1s
1013! ==================================================================
1014SUBROUTINE realloc_i2s( array, i1max, i2max,  &
1015                        name, routine, copy, shrink )
1016implicit none
1017integer, dimension(:,:),    pointer    :: array
1018integer,                    intent(in) :: i1max, i2max
1019character(len=*), optional, intent(in) :: name, routine
1020logical,          optional, intent(in) :: copy, shrink
1021call realloc_i2( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1022                 name, routine, copy, shrink )
1023END SUBROUTINE realloc_i2s
1024! ==================================================================
1025SUBROUTINE realloc_i3s( array, i1max, i2max, i3max,  &
1026                        name, routine, copy, shrink )
1027implicit none
1028integer, dimension(:,:,:),  pointer    :: array
1029integer,                    intent(in) :: i1max, i2max, i3max
1030character(len=*), optional, intent(in) :: name, routine
1031logical,          optional, intent(in) :: copy, shrink
1032call realloc_i3( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1033                 DEFAULT%imin, i3max,                             &
1034                 name, routine, copy, shrink )
1035END SUBROUTINE realloc_i3s
1036! ==================================================================
1037SUBROUTINE realloc_r1s( array, i1max, &
1038                        name, routine, copy, shrink )
1039implicit none
1040real(SP), dimension(:),     pointer    :: array
1041integer,                    intent(in) :: i1max
1042character(len=*), optional, intent(in) :: name, routine
1043logical,          optional, intent(in) :: copy, shrink
1044call realloc_r1( array, DEFAULT%imin, i1max, &
1045                 name, routine, copy, shrink )
1046END SUBROUTINE realloc_r1s
1047! ==================================================================
1048SUBROUTINE realloc_r2s( array, i1max, i2max, &
1049                        name, routine, copy, shrink )
1050implicit none
1051real(SP), dimension(:,:),   pointer    :: array
1052integer,                    intent(in) :: i1max, i2max
1053character(len=*), optional, intent(in) :: name, routine
1054logical,          optional, intent(in) :: copy, shrink
1055call realloc_r2( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1056                 name, routine, copy, shrink )
1057END SUBROUTINE realloc_r2s
1058! ==================================================================
1059SUBROUTINE realloc_r3s( array, i1max, i2max, i3max, &
1060                        name, routine, copy, shrink )
1061implicit none
1062real(SP), dimension(:,:,:), pointer    :: array
1063integer,                    intent(in) :: i1max, i2max, i3max
1064character(len=*), optional, intent(in) :: name, routine
1065logical,          optional, intent(in) :: copy, shrink
1066call realloc_r3( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1067                 DEFAULT%imin, i3max,                             &
1068                 name, routine, copy, shrink )
1069END SUBROUTINE realloc_r3s
1070! ==================================================================
1071SUBROUTINE realloc_r4s( array, i1max, i2max, i3max, i4max, &
1072                        name, routine, copy, shrink )
1073implicit none
1074real(SP), dimension(:,:,:,:), pointer  :: array
1075integer,                    intent(in) :: i1max, i2max, i3max, i4max
1076character(len=*), optional, intent(in) :: name, routine
1077logical,          optional, intent(in) :: copy, shrink
1078call realloc_r4( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1079                        DEFAULT%imin, i3max, DEFAULT%imin, i4max, &
1080                 name, routine, copy, shrink )
1081END SUBROUTINE realloc_r4s
1082! ==================================================================
1083SUBROUTINE realloc_d1s( array, i1max, &
1084                        name, routine, copy, shrink )
1085implicit none
1086real(DP), dimension(:),     pointer    :: array
1087integer,                    intent(in) :: i1max
1088character(len=*), optional, intent(in) :: name, routine
1089logical,          optional, intent(in) :: copy, shrink
1090call realloc_d1( array, DEFAULT%imin, i1max, &
1091                 name, routine, copy, shrink )
1092END SUBROUTINE realloc_d1s
1093! ==================================================================
1094SUBROUTINE realloc_d2s( array, i1max, i2max, &
1095                        name, routine, copy, shrink )
1096implicit none
1097real(DP), dimension(:,:),   pointer    :: array
1098integer,                    intent(in) :: i1max, i2max
1099character(len=*), optional, intent(in) :: name, routine
1100logical,          optional, intent(in) :: copy, shrink
1101call realloc_d2( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1102                 name, routine, copy, shrink )
1103END SUBROUTINE realloc_d2s
1104! ==================================================================
1105SUBROUTINE realloc_d3s( array, i1max, i2max, i3max, &
1106                        name, routine, copy, shrink )
1107implicit none
1108real(DP), dimension(:,:,:), pointer    :: array
1109integer,                    intent(in) :: i1max, i2max, i3max
1110character(len=*), optional, intent(in) :: name, routine
1111logical,          optional, intent(in) :: copy, shrink
1112call realloc_d3( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1113                 DEFAULT%imin, i3max,                             &
1114                 name, routine, copy, shrink )
1115END SUBROUTINE realloc_d3s
1116! ==================================================================
1117SUBROUTINE realloc_d4s( array, i1max, i2max, i3max, i4max, &
1118                        name, routine, copy, shrink )
1119implicit none
1120real(DP), dimension(:,:,:,:), pointer  :: array
1121integer,                    intent(in) :: i1max, i2max, i3max, i4max
1122character(len=*), optional, intent(in) :: name, routine
1123logical,          optional, intent(in) :: copy, shrink
1124call realloc_d4( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1125                        DEFAULT%imin, i3max, DEFAULT%imin, i4max, &
1126                 name, routine, copy, shrink )
1127END SUBROUTINE realloc_d4s
1128! ==================================================================
1129SUBROUTINE realloc_l1s( array, i1max, &
1130                        name, routine, copy, shrink )
1131implicit none
1132logical, dimension(:),      pointer    :: array
1133integer,                    intent(in) :: i1max
1134character(len=*), optional, intent(in) :: name
1135character(len=*), optional, intent(in) :: routine
1136logical,          optional, intent(in) :: copy
1137logical,          optional, intent(in) :: shrink
1138call realloc_l1( array, DEFAULT%imin, i1max, &
1139                 name, routine, copy, shrink )
1140END SUBROUTINE realloc_l1s
1141! ==================================================================
1142SUBROUTINE realloc_l2s( array, i1max, i2max, &
1143                        name, routine, copy, shrink )
1144implicit none
1145logical, dimension(:,:),    pointer    :: array
1146integer,                    intent(in) :: i1max, i2max
1147character(len=*), optional, intent(in) :: name
1148character(len=*), optional, intent(in) :: routine
1149logical,          optional, intent(in) :: copy
1150logical,          optional, intent(in) :: shrink
1151call realloc_l2( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1152                 name, routine, copy, shrink )
1153END SUBROUTINE realloc_l2s
1154! ==================================================================
1155SUBROUTINE realloc_l3s( array, i1max, i2max, i3max, &
1156                        name, routine, copy, shrink )
1157implicit none
1158logical, dimension(:,:,:),  pointer    :: array
1159integer,                    intent(in) :: i1max, i2max, i3max
1160character(len=*), optional, intent(in) :: name
1161character(len=*), optional, intent(in) :: routine
1162logical,          optional, intent(in) :: copy
1163logical,          optional, intent(in) :: shrink
1164call realloc_l3( array, DEFAULT%imin, i1max, DEFAULT%imin, i2max, &
1165                 DEFAULT%imin, i3max, name, routine, copy, shrink )
1166END SUBROUTINE realloc_l3s
1167! ==================================================================
1168! Character vector realloc
1169! ==================================================================
1170SUBROUTINE realloc_s1( array, i1min, i1max, &
1171                       name, routine, copy, shrink )
1172! Arguments
1173implicit none
1174character(len=*), dimension(:),      pointer    :: array
1175integer,                    intent(in) :: i1min
1176integer,                    intent(in) :: i1max
1177character(len=*), optional, intent(in) :: name
1178character(len=*), optional, intent(in) :: routine
1179logical,          optional, intent(in) :: copy
1180logical,          optional, intent(in) :: shrink
1181
1182! Internal variables and arrays
1183character, parameter           :: type='S'
1184integer, parameter             :: rank=1
1185character(len=len(array)), dimension(:), pointer :: old_array
1186integer, dimension(2,rank)     :: b, c, new_bounds, old_bounds
1187
1188! Get old array bounds
1189ASSOCIATED_ARRAY = associated(array)
1190if (ASSOCIATED_ARRAY) then
1191  old_array => array          ! Keep pointer to old array
1192  old_bounds(1,:) = lbound(old_array)
1193  old_bounds(2,:) = ubound(old_array)
1194end if
1195
1196! Copy new requested array bounds
1197new_bounds(1,:) = (/ i1min /)
1198new_bounds(2,:) = (/ i1max /)
1199
1200! Find if it is a new allocation or a true reallocation,
1201! and if the contents need to be copied (saved)
1202! Argument b returns common bounds
1203! Options routine also reads common variable ASSOCIATED_ARRAY,
1204! and it sets NEEDS_ALLOC, NEEDS_DEALLOC, and NEEDS_COPY
1205call options( b, c, old_bounds, new_bounds, copy, shrink )
1206
1207! Deallocate old space
1208if (NEEDS_DEALLOC .and. .not.NEEDS_COPY) then
1209  call alloc_count( -size(old_array)*len(old_array), type, name, routine )
1210  deallocate(old_array,stat=IERR)
1211  call alloc_err( IERR, name, routine, old_bounds )
1212end if
1213
1214! Allocate new space
1215if (NEEDS_ALLOC) then
1216  allocate( array(b(1,1):b(2,1)), stat=IERR )
1217  call alloc_err( IERR, name, routine, new_bounds )
1218  call alloc_count( size(array)*len(array), type, name, routine )
1219  array = ''
1220end if
1221
1222! Copy contents and deallocate old space
1223if (NEEDS_COPY) then
1224  array(c(1,1):c(2,1)) = old_array(c(1,1):c(2,1))
1225  call alloc_count( -size(old_array)*len(old_array), type, name, routine )
1226  deallocate(old_array,stat=IERR)
1227  call alloc_err( IERR, name, routine, old_bounds )
1228end if
1229
1230END SUBROUTINE realloc_s1
1231! ==================================================================
1232! Dealloc routines
1233! ==================================================================
1234SUBROUTINE dealloc_i1( array, name, routine )
1235
1236! Arguments
1237implicit none
1238integer, dimension(:),      pointer    :: array
1239character(len=*), optional, intent(in) :: name
1240character(len=*), optional, intent(in) :: routine
1241
1242if (associated(array)) then
1243  call alloc_count( -size(array), 'I', name, routine )
1244  deallocate(array,stat=IERR)
1245  call alloc_err( IERR, name, routine )
1246end if
1247
1248END SUBROUTINE dealloc_i1
1249
1250! ==================================================================
1251SUBROUTINE dealloc_i2( array, name, routine )
1252implicit none
1253integer, dimension(:,:),    pointer    :: array
1254character(len=*), optional, intent(in) :: name, routine
1255if (associated(array)) then
1256  call alloc_count( -size(array), 'I', name, routine )
1257  deallocate(array,stat=IERR)
1258  call alloc_err( IERR, name, routine )
1259
1260end if
1261END SUBROUTINE dealloc_i2
1262! ==================================================================
1263SUBROUTINE dealloc_i3( array, name, routine )
1264implicit none
1265integer, dimension(:,:,:),  pointer    :: array
1266character(len=*), optional, intent(in) :: name, routine
1267if (associated(array)) then
1268  call alloc_count( -size(array), 'I', name, routine )
1269  deallocate(array,stat=IERR)
1270  call alloc_err( IERR, name, routine )
1271
1272end if
1273END SUBROUTINE dealloc_i3
1274! ==================================================================
1275SUBROUTINE dealloc_E1( array, name, routine )
1276
1277! Arguments
1278implicit none
1279integer, parameter :: i8b = selected_int_kind(18)
1280integer(i8b), dimension(:),      pointer    :: array
1281character(len=*), optional, intent(in) :: name
1282character(len=*), optional, intent(in) :: routine
1283
1284if (associated(array)) then
1285  call alloc_count( -size(array), 'I', name, routine )
1286  deallocate(array,stat=IERR)
1287  call alloc_err( IERR, name, routine )
1288
1289end if
1290
1291END SUBROUTINE dealloc_E1
1292
1293! ==================================================================
1294SUBROUTINE dealloc_r1( array, name, routine )
1295implicit none
1296real(SP), dimension(:),     pointer    :: array
1297character(len=*), optional, intent(in) :: name, routine
1298if (associated(array)) then
1299  call alloc_count( -size(array), 'R', name, routine )
1300  deallocate(array,stat=IERR)
1301  call alloc_err( IERR, name, routine )
1302end if
1303END SUBROUTINE dealloc_r1
1304! ==================================================================
1305SUBROUTINE dealloc_r2( array, name, routine )
1306implicit none
1307real(SP), dimension(:,:),   pointer    :: array
1308character(len=*), optional, intent(in) :: name, routine
1309if (associated(array)) then
1310  call alloc_count( -size(array), 'R', name, routine )
1311  deallocate(array,stat=IERR)
1312  call alloc_err( IERR, name, routine )
1313end if
1314END SUBROUTINE dealloc_r2
1315! ==================================================================
1316SUBROUTINE dealloc_r3( array, name, routine )
1317implicit none
1318real(SP), dimension(:,:,:), pointer    :: array
1319character(len=*), optional, intent(in) :: name, routine
1320if (associated(array)) then
1321  call alloc_count( -size(array), 'R', name, routine )
1322  deallocate(array,stat=IERR)
1323  call alloc_err( IERR, name, routine )
1324end if
1325END SUBROUTINE dealloc_r3
1326! ==================================================================
1327SUBROUTINE dealloc_r4( array, name, routine )
1328implicit none
1329real(SP), dimension(:,:,:,:), pointer  :: array
1330character(len=*), optional, intent(in) :: name, routine
1331if (associated(array)) then
1332  call alloc_count( -size(array), 'R', name, routine )
1333  deallocate(array,stat=IERR)
1334  call alloc_err( IERR, name, routine )
1335end if
1336END SUBROUTINE dealloc_r4
1337! ==================================================================
1338SUBROUTINE dealloc_d1( array, name, routine )
1339implicit none
1340real(DP), dimension(:),     pointer    :: array
1341character(len=*), optional, intent(in) :: name, routine
1342if (associated(array)) then
1343  call alloc_count( -size(array), 'D', name, routine )
1344  deallocate(array,stat=IERR)
1345  call alloc_err( IERR, name, routine )
1346end if
1347END SUBROUTINE dealloc_d1
1348! ==================================================================
1349SUBROUTINE dealloc_d2( array, name, routine )
1350implicit none
1351real(DP), dimension(:,:),   pointer    :: array
1352character(len=*), optional, intent(in) :: name, routine
1353if (associated(array)) then
1354  call alloc_count( -size(array), 'D', name, routine )
1355  deallocate(array,stat=IERR)
1356  call alloc_err( IERR, name, routine )
1357end if
1358END SUBROUTINE dealloc_d2
1359! ==================================================================
1360SUBROUTINE dealloc_d3( array, name, routine )
1361implicit none
1362real(DP), dimension(:,:,:), pointer    :: array
1363character(len=*), optional, intent(in) :: name, routine
1364if (associated(array)) then
1365  call alloc_count( -size(array), 'D', name, routine )
1366  deallocate(array,stat=IERR)
1367  call alloc_err( IERR, name, routine )
1368end if
1369END SUBROUTINE dealloc_d3
1370! ==================================================================
1371SUBROUTINE dealloc_d4( array, name, routine )
1372implicit none
1373real(DP), dimension(:,:,:,:), pointer  :: array
1374character(len=*), optional, intent(in) :: name, routine
1375if (associated(array)) then
1376  call alloc_count( -size(array), 'D', name, routine )
1377  deallocate(array,stat=IERR)
1378  call alloc_err( IERR, name, routine )
1379end if
1380END SUBROUTINE dealloc_d4
1381! ==================================================================
1382! COMPLEX versions
1383!
1384SUBROUTINE dealloc_z1( array, name, routine )
1385implicit none
1386complex(DP), dimension(:),   pointer   :: array
1387character(len=*), optional, intent(in) :: name, routine
1388if (associated(array)) then
1389  call alloc_count( -2*size(array), 'D', name, routine )
1390  deallocate(array,stat=IERR)
1391  call alloc_err( IERR, name, routine )
1392end if
1393END SUBROUTINE dealloc_z1
1394! ==================================================================
1395SUBROUTINE dealloc_z2( array, name, routine )
1396implicit none
1397complex(DP), dimension(:,:),  pointer  :: array
1398character(len=*), optional, intent(in) :: name, routine
1399if (associated(array)) then
1400  call alloc_count( -2*size(array), 'D', name, routine )
1401  deallocate(array,stat=IERR)
1402  call alloc_err( IERR, name, routine )
1403end if
1404END SUBROUTINE dealloc_z2
1405! ==================================================================
1406SUBROUTINE dealloc_l1( array, name, routine )
1407implicit none
1408logical, dimension(:),      pointer    :: array
1409character(len=*), optional, intent(in) :: name, routine
1410if (associated(array)) then
1411  call alloc_count( -size(array), 'L', name, routine )
1412  deallocate(array,stat=IERR)
1413  call alloc_err( IERR, name, routine )
1414end if
1415END SUBROUTINE dealloc_l1
1416! ==================================================================
1417SUBROUTINE dealloc_l2( array, name, routine )
1418implicit none
1419logical, dimension(:,:),    pointer    :: array
1420character(len=*), optional, intent(in) :: name, routine
1421if (associated(array)) then
1422  call alloc_count( -size(array), 'L', name, routine )
1423  deallocate(array,stat=IERR)
1424  call alloc_err( IERR, name, routine )
1425end if
1426END SUBROUTINE dealloc_l2
1427! ==================================================================
1428SUBROUTINE dealloc_l3( array, name, routine )
1429implicit none
1430logical, dimension(:,:,:),  pointer    :: array
1431character(len=*), optional, intent(in) :: name, routine
1432if (associated(array)) then
1433  call alloc_count( -size(array), 'L', name, routine )
1434  deallocate(array,stat=IERR)
1435  call alloc_err( IERR, name, routine )
1436end if
1437END SUBROUTINE dealloc_l3
1438! ==================================================================
1439SUBROUTINE dealloc_s1( array, name, routine )
1440implicit none
1441character(len=*), dimension(:), pointer :: array
1442character(len=*), optional, intent(in)  :: name, routine
1443if (associated(array)) then
1444  call alloc_count( -size(array)*len(array), 'S', name, routine )
1445  deallocate(array,stat=IERR)
1446  call alloc_err( IERR, name, routine )
1447end if
1448END SUBROUTINE dealloc_s1
1449
1450! ==================================================================
1451! Internal subroutines
1452! ==================================================================
1453
1454SUBROUTINE options( final_bounds, common_bounds, &
1455                    old_bounds, new_bounds, copy, shrink )
1456! Arguments
1457integer, dimension(:,:), intent(out) :: final_bounds
1458integer, dimension(:,:), intent(out) :: common_bounds
1459integer, dimension(:,:), intent(in)  :: old_bounds
1460integer, dimension(:,:), intent(in)  :: new_bounds
1461logical,       optional, intent(in)  :: copy
1462logical,       optional, intent(in)  :: shrink
1463
1464! Internal variables and arrays
1465logical want_shrink
1466
1467
1468!! AG*****
1469!  It might be worthwhile to check whether the user
1470!  atttemps to use bounds which do not make sense,
1471!  such as zero, or with upper<lower...
1472!!***
1473
1474! Find if it is a new allocation or a true reallocation,
1475! and if the contents need to be copied (saved)
1476if (ASSOCIATED_ARRAY) then
1477
1478  ! Check if array bounds have changed
1479  if ( all(new_bounds==old_bounds) ) then
1480    ! Old and new arrays are equal. Nothing needs to be done
1481    NEEDS_ALLOC   = .false.
1482    NEEDS_DEALLOC = .false.
1483    NEEDS_COPY    = .false.
1484  else
1485
1486    ! Want to shrink?
1487    if (present(shrink)) then
1488      want_shrink = shrink
1489    else
1490      want_shrink = DEFAULT%shrink
1491    end if
1492
1493    if (.not. want_shrink  &
1494        .and. all(new_bounds(1,:)>=old_bounds(1,:)) &
1495        .and. all(new_bounds(2,:)<=old_bounds(2,:)) ) then
1496      ! Old array is already fine. Nothing needs to be done
1497      NEEDS_ALLOC   = .false.
1498      NEEDS_DEALLOC = .false.
1499      NEEDS_COPY    = .false.
1500    else
1501      ! Old array needs to be substituted by a new array
1502      NEEDS_ALLOC   = .true.
1503      NEEDS_DEALLOC = .true.
1504      if (present(copy)) then
1505        NEEDS_COPY = copy
1506      else
1507        NEEDS_COPY = DEFAULT%copy
1508      end if
1509
1510      ! Ensure that bounds shrink only if desired
1511      if (want_shrink) then
1512        final_bounds(1,:) = new_bounds(1,:)
1513        final_bounds(2,:) = new_bounds(2,:)
1514      else
1515        final_bounds(1,:) = min( old_bounds(1,:), new_bounds(1,:) )
1516        final_bounds(2,:) = max( old_bounds(2,:), new_bounds(2,:) )
1517      end if
1518
1519      ! Find common section of old and new arrays
1520      common_bounds(1,:) = max( old_bounds(1,:), final_bounds(1,:) )
1521      common_bounds(2,:) = min( old_bounds(2,:), final_bounds(2,:) )
1522    end if
1523
1524  end if
1525
1526else
1527  ! Old array does not exist. Allocate new one
1528  NEEDS_ALLOC   = .true.
1529  NEEDS_DEALLOC = .false.
1530  NEEDS_COPY    = .false.
1531  final_bounds(1,:) = new_bounds(1,:)
1532  final_bounds(2,:) = new_bounds(2,:)
1533end if
1534
1535END SUBROUTINE options
1536
1537! ==================================================================
1538
1539SUBROUTINE alloc_err( ierr, name, routine, bounds )
1540implicit none
1541
1542integer,                    intent(in) :: ierr
1543character(len=*), optional, intent(in) :: name
1544character(len=*), optional, intent(in) :: routine
1545integer, dimension(:,:), optional, intent(in) :: bounds
1546
1547integer i
1548character(len=128) :: msg
1549
1550if (ierr/=0) then
1551   write(msg,*) 'alloc_err: allocate status error', ierr
1552   call alloc_error_report(trim(msg),1)
1553  if (present(name).and.present(routine)) then
1554     write(msg,*) 'alloc_err: array ', name, &
1555               ' requested by ', routine
1556     call alloc_error_report(trim(msg),2)
1557  elseif (present(name)) then
1558     write(msg,*) 'alloc_err: array ', name, &
1559               ' requested by unknown'
1560     call alloc_error_report(trim(msg),3)
1561  elseif (present(routine)) then
1562     write(msg,*) 'alloc_err: array unknown', &
1563               ' requested by ', routine
1564     call alloc_error_report(trim(msg),4)
1565  endif
1566  if (present(bounds)) then
1567     write(msg,'(a,i3,2i10)') ('alloc_err: dim, lbound, ubound:',  &
1568          i,bounds(1,i),bounds(2,i),                         &
1569          i=1,size(bounds,dim=2))
1570     call alloc_error_report(trim(msg),5)
1571  endif
1572  call alloc_error_report("alloc_err: end of error report",0)
1573end if
1574
1575END SUBROUTINE alloc_err
1576
1577! ==================================================================
1578
1579SUBROUTINE alloc_count( delta_size, type, name, routine )
1580
1581!
1582!  This version simply computes the total size and calls
1583!  the external routine  alloc_memory_event with the size
1584!  in bytes and a string identifier of the form 'routine@name'.
1585!
1586implicit none
1587
1588integer, intent(in)          :: delta_size  ! +/-size(array)
1589character, intent(in)        :: type        ! 'I' => integer
1590                                            ! 'E' => integer*8
1591                                            ! 'R' => real*4
1592                                            ! 'D' => real*8
1593                                            ! 'L' => logical
1594                                            ! 'S' => character (string)
1595character(len=*), optional, intent(in) :: name
1596character(len=*), optional, intent(in) :: routine
1597
1598character(len=32)   :: aname
1599integer             :: bytes
1600
1601! Compound routine+array name
1602if (present(name) .and. present(routine)) then
1603  aname = trim(routine)//'@'//name
1604else if (present(name) .and. DEFAULT%routine/=DEFAULT_ROUTINE) then
1605  aname = trim(DEFAULT%routine)//'@'//name
1606else if (present(name)) then
1607  aname = trim(DEFAULT_ROUTINE)//'@'//name
1608else if (present(routine)) then
1609  aname = trim(routine)//'@'//DEFAULT_NAME
1610else if (DEFAULT%routine/=DEFAULT_ROUTINE) then
1611  aname = trim(DEFAULT%routine)//'@'//DEFAULT_NAME
1612else
1613  aname = DEFAULT_ROUTINE//'@'//DEFAULT_NAME
1614end if
1615
1616! Find memory increment and total allocated memory
1617bytes = delta_size * type_mem(type)
1618
1619call alloc_memory_event(bytes,trim(aname))
1620
1621CONTAINS
1622
1623  INTEGER FUNCTION type_mem( var_type )
1624!
1625! It is not clear that the sizes assumed are universal for
1626! non-Cray machines...
1627!
1628implicit none
1629character, intent(in) :: var_type
1630character(len=40)     :: message
1631
1632select case( var_type )
1633#ifdef OLD_CRAY
1634  case('I')
1635    type_mem = 8
1636  case('R')
1637    type_mem = 8
1638  case('L')
1639    type_mem = 8
1640#else
1641  case('I')
1642    type_mem = 4
1643  case('R')
1644    type_mem = 4
1645  case('L')
1646    type_mem = 4
1647#endif
1648case('E')
1649  type_mem = 8
1650case('D')
1651  type_mem = 8
1652case('S')
1653  type_mem = 1
1654case default
1655  write(message,"(2a)") &
1656    'alloc_count: ERROR: unknown type = ', var_type
1657  call alloc_error_report(trim(message),0)
1658end select
1659
1660END FUNCTION type_mem
1661
1662END SUBROUTINE alloc_count
1663
1664END MODULE alloc
1665
1666#ifdef __TEST__MODULE__ALLOC__
1667! Optional test code
1668!
1669program testalloc
1670use alloc, only: re_alloc, de_alloc
1671
1672real, pointer :: x(:) => null()
1673real(kind=kind(1.d0)), pointer :: y(:,:) => null()
1674
1675call re_alloc(x,1,10,"x","testalloc")
1676call re_alloc(y,-3,4,1,3,"y","testalloc")
1677print *, "Shape of x: ", shape(x)
1678print *, "Shape of y: ", shape(y)
1679call de_alloc(x,"x","testalloc")
1680call de_alloc(y,"y","testalloc")
1681
1682end program testalloc
1683!
1684! Handlers
1685! Note: In systems with weak symbols, these handlers
1686! could be compiled marked as such. (Future extension)
1687!
1688subroutine alloc_memory_event(bytes,name)
1689integer, intent(in) :: bytes
1690character(len=*), intent(in) :: name
1691write(*,*) "alloc: allocated ", bytes, "bytes for "//trim(name)
1692end subroutine alloc_memory_event
1693
1694subroutine alloc_error_report(name,code)
1695character(len=*), intent(in) :: name
1696integer, intent(in) :: code
1697write(*,*) "alloc error: "//trim(name)
1698end subroutine alloc_error_report
1699
1700#endif
1701
1702