(git:374b731)
Loading...
Searching...
No Matches
memory_utilities.F
Go to the documentation of this file.
1!--------------------------------------------------------------------------------------------------!
2! CP2K: A general program to perform molecular dynamics simulations !
3! Copyright 2000-2024 CP2K developers group <https://cp2k.org> !
4! !
5! SPDX-License-Identifier: GPL-2.0-or-later !
6!--------------------------------------------------------------------------------------------------!
7
8! **************************************************************************************************
9!> \brief Utility routines for the memory handling.
10!> \par History
11!> (12.2017) remove stop_memory
12!> \author Matthias Krack (25.06.1999)
13! **************************************************************************************************
14MODULE memory_utilities
15
16 USE kinds, ONLY: dp, int_8
17#include "../base/base_uses.f90"
18
19 IMPLICIT NONE
20
21 PRIVATE
22
23 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'memory_utilities'
24
25 PUBLIC :: reallocate
26
27 INTERFACE reallocate
28 MODULE PROCEDURE reallocate_c1, reallocate_c2, reallocate_c3, reallocate_c4, &
29 reallocate_i1, reallocate_i2, reallocate_i3, reallocate_i4, &
30 reallocate_r1, reallocate_r2, reallocate_r3, reallocate_r4, &
31 reallocate_r5, reallocate_s1, reallocate_l1, reallocate_8i1, &
32 reallocate_8i2
33 END INTERFACE
34
35CONTAINS
36
37
38! **************************************************************************************************
39!> \brief (Re)Allocate a 1D vector of type COMPLEX(KIND=dp) with new dimensions (but same shape)
40!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
41!> \param lb1_new new lower bound for dimension 1
42!> \param ub1_new new upper bound for dimension 1
43! **************************************************************************************************
44 SUBROUTINE reallocate_c1 (p, lb1_new,ub1_new)
45 COMPLEX(KIND=dp), &
46 DIMENSION(:), &
47 POINTER, INTENT(INOUT) :: p
48
49 INTEGER, INTENT(IN) :: &
50 lb1_new,ub1_new
51
52 INTEGER :: lb1, lb1_old, ub1, ub1_old
53
54 COMPLEX(KIND=dp), &
55 DIMENSION(:), &
56 POINTER :: work
57
58 NULLIFY (work)
59
60 IF (ASSOCIATED(p)) THEN
61 lb1_old = lbound(p, 1)
62 ub1_old = ubound(p, 1)
63 lb1 = max(lb1_new, lb1_old)
64 ub1 = min(ub1_new, ub1_old)
65 work => p
66 END IF
67
68 ALLOCATE (p(lb1_new:ub1_new))
69 p = (0.0_dp, 0.0_dp)
70
71 IF (ASSOCIATED(work)) THEN
72 p(lb1:ub1) = work(lb1:ub1)
73 DEALLOCATE (work)
74 END IF
75
76 END SUBROUTINE reallocate_c1
77! **************************************************************************************************
78!> \brief (Re)Allocate a 2D vector of type COMPLEX(KIND=dp) with new dimensions (but same shape)
79!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
80!> \param lb1_new new lower bound for dimension 1
81!> \param ub1_new new upper bound for dimension 1
82!> \param lb2_new new lower bound for dimension 2
83!> \param ub2_new new upper bound for dimension 2
84! **************************************************************************************************
85 SUBROUTINE reallocate_c2 (p, lb1_new,ub1_new,lb2_new,ub2_new)
86 COMPLEX(KIND=dp), &
87 DIMENSION(:,:), &
88 POINTER, INTENT(INOUT) :: p
89
90 INTEGER, INTENT(IN) :: &
91 lb1_new,ub1_new,lb2_new,ub2_new
92
93 INTEGER :: lb1, lb1_old, ub1, ub1_old
94 INTEGER :: lb2, lb2_old, ub2, ub2_old
95
96 COMPLEX(KIND=dp), &
97 DIMENSION(:,:), &
98 POINTER :: work
99
100 NULLIFY (work)
101
102 IF (ASSOCIATED(p)) THEN
103 lb1_old = lbound(p, 1)
104 ub1_old = ubound(p, 1)
105 lb1 = max(lb1_new, lb1_old)
106 ub1 = min(ub1_new, ub1_old)
107 lb2_old = lbound(p, 2)
108 ub2_old = ubound(p, 2)
109 lb2 = max(lb2_new, lb2_old)
110 ub2 = min(ub2_new, ub2_old)
111 work => p
112 END IF
113
114 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new))
115 p = (0.0_dp, 0.0_dp)
116
117 IF (ASSOCIATED(work)) THEN
118 p(lb1:ub1,lb2:ub2) = work(lb1:ub1,lb2:ub2)
119 DEALLOCATE (work)
120 END IF
121
122 END SUBROUTINE reallocate_c2
123! **************************************************************************************************
124!> \brief (Re)Allocate a 3D vector of type COMPLEX(KIND=dp) with new dimensions (but same shape)
125!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
126!> \param lb1_new new lower bound for dimension 1
127!> \param ub1_new new upper bound for dimension 1
128!> \param lb2_new new lower bound for dimension 2
129!> \param ub2_new new upper bound for dimension 2
130!> \param lb3_new new lower bound for dimension 3
131!> \param ub3_new new upper bound for dimension 3
132! **************************************************************************************************
133 SUBROUTINE reallocate_c3 (p, lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new)
134 COMPLEX(KIND=dp), &
135 DIMENSION(:,:,:), &
136 POINTER, INTENT(INOUT) :: p
137
138 INTEGER, INTENT(IN) :: &
139 lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new
140
141 INTEGER :: lb1, lb1_old, ub1, ub1_old
142 INTEGER :: lb2, lb2_old, ub2, ub2_old
143 INTEGER :: lb3, lb3_old, ub3, ub3_old
144
145 COMPLEX(KIND=dp), &
146 DIMENSION(:,:,:), &
147 POINTER :: work
148
149 NULLIFY (work)
150
151 IF (ASSOCIATED(p)) THEN
152 lb1_old = lbound(p, 1)
153 ub1_old = ubound(p, 1)
154 lb1 = max(lb1_new, lb1_old)
155 ub1 = min(ub1_new, ub1_old)
156 lb2_old = lbound(p, 2)
157 ub2_old = ubound(p, 2)
158 lb2 = max(lb2_new, lb2_old)
159 ub2 = min(ub2_new, ub2_old)
160 lb3_old = lbound(p, 3)
161 ub3_old = ubound(p, 3)
162 lb3 = max(lb3_new, lb3_old)
163 ub3 = min(ub3_new, ub3_old)
164 work => p
165 END IF
166
167 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new,lb3_new:ub3_new))
168 p = (0.0_dp, 0.0_dp)
169
170 IF (ASSOCIATED(work)) THEN
171 p(lb1:ub1,lb2:ub2,lb3:ub3) = work(lb1:ub1,lb2:ub2,lb3:ub3)
172 DEALLOCATE (work)
173 END IF
174
175 END SUBROUTINE reallocate_c3
176! **************************************************************************************************
177!> \brief (Re)Allocate a 4D vector of type COMPLEX(KIND=dp) with new dimensions (but same shape)
178!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
179!> \param lb1_new new lower bound for dimension 1
180!> \param ub1_new new upper bound for dimension 1
181!> \param lb2_new new lower bound for dimension 2
182!> \param ub2_new new upper bound for dimension 2
183!> \param lb3_new new lower bound for dimension 3
184!> \param ub3_new new upper bound for dimension 3
185!> \param lb4_new new lower bound for dimension 4
186!> \param ub4_new new upper bound for dimension 4
187! **************************************************************************************************
188 SUBROUTINE reallocate_c4 (p, lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new)
189 COMPLEX(KIND=dp), &
190 DIMENSION(:,:,:,:), &
191 POINTER, INTENT(INOUT) :: p
192
193 INTEGER, INTENT(IN) :: &
194 lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new
195
196 INTEGER :: lb1, lb1_old, ub1, ub1_old
197 INTEGER :: lb2, lb2_old, ub2, ub2_old
198 INTEGER :: lb3, lb3_old, ub3, ub3_old
199 INTEGER :: lb4, lb4_old, ub4, ub4_old
200
201 COMPLEX(KIND=dp), &
202 DIMENSION(:,:,:,:), &
203 POINTER :: work
204
205 NULLIFY (work)
206
207 IF (ASSOCIATED(p)) THEN
208 lb1_old = lbound(p, 1)
209 ub1_old = ubound(p, 1)
210 lb1 = max(lb1_new, lb1_old)
211 ub1 = min(ub1_new, ub1_old)
212 lb2_old = lbound(p, 2)
213 ub2_old = ubound(p, 2)
214 lb2 = max(lb2_new, lb2_old)
215 ub2 = min(ub2_new, ub2_old)
216 lb3_old = lbound(p, 3)
217 ub3_old = ubound(p, 3)
218 lb3 = max(lb3_new, lb3_old)
219 ub3 = min(ub3_new, ub3_old)
220 lb4_old = lbound(p, 4)
221 ub4_old = ubound(p, 4)
222 lb4 = max(lb4_new, lb4_old)
223 ub4 = min(ub4_new, ub4_old)
224 work => p
225 END IF
226
227 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new,lb3_new:ub3_new,lb4_new:ub4_new))
228 p = (0.0_dp, 0.0_dp)
229
230 IF (ASSOCIATED(work)) THEN
231 p(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4) = work(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4)
232 DEALLOCATE (work)
233 END IF
234
235 END SUBROUTINE reallocate_c4
236! **************************************************************************************************
237!> \brief (Re)Allocate a 1D vector of type INTEGER with new dimensions (but same shape)
238!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
239!> \param lb1_new new lower bound for dimension 1
240!> \param ub1_new new upper bound for dimension 1
241! **************************************************************************************************
242 SUBROUTINE reallocate_i1 (p, lb1_new,ub1_new)
243 INTEGER, &
244 DIMENSION(:), &
245 POINTER, INTENT(INOUT) :: p
246
247 INTEGER, INTENT(IN) :: &
248 lb1_new,ub1_new
249
250 INTEGER :: lb1, lb1_old, ub1, ub1_old
251
252 INTEGER, &
253 DIMENSION(:), &
254 POINTER :: work
255
256 NULLIFY (work)
257
258 IF (ASSOCIATED(p)) THEN
259 lb1_old = lbound(p, 1)
260 ub1_old = ubound(p, 1)
261 lb1 = max(lb1_new, lb1_old)
262 ub1 = min(ub1_new, ub1_old)
263 work => p
264 END IF
265
266 ALLOCATE (p(lb1_new:ub1_new))
267 p = 0
268
269 IF (ASSOCIATED(work)) THEN
270 p(lb1:ub1) = work(lb1:ub1)
271 DEALLOCATE (work)
272 END IF
273
274 END SUBROUTINE reallocate_i1
275! **************************************************************************************************
276!> \brief (Re)Allocate a 2D vector of type INTEGER with new dimensions (but same shape)
277!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
278!> \param lb1_new new lower bound for dimension 1
279!> \param ub1_new new upper bound for dimension 1
280!> \param lb2_new new lower bound for dimension 2
281!> \param ub2_new new upper bound for dimension 2
282! **************************************************************************************************
283 SUBROUTINE reallocate_i2 (p, lb1_new,ub1_new,lb2_new,ub2_new)
284 INTEGER, &
285 DIMENSION(:,:), &
286 POINTER, INTENT(INOUT) :: p
287
288 INTEGER, INTENT(IN) :: &
289 lb1_new,ub1_new,lb2_new,ub2_new
290
291 INTEGER :: lb1, lb1_old, ub1, ub1_old
292 INTEGER :: lb2, lb2_old, ub2, ub2_old
293
294 INTEGER, &
295 DIMENSION(:,:), &
296 POINTER :: work
297
298 NULLIFY (work)
299
300 IF (ASSOCIATED(p)) THEN
301 lb1_old = lbound(p, 1)
302 ub1_old = ubound(p, 1)
303 lb1 = max(lb1_new, lb1_old)
304 ub1 = min(ub1_new, ub1_old)
305 lb2_old = lbound(p, 2)
306 ub2_old = ubound(p, 2)
307 lb2 = max(lb2_new, lb2_old)
308 ub2 = min(ub2_new, ub2_old)
309 work => p
310 END IF
311
312 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new))
313 p = 0
314
315 IF (ASSOCIATED(work)) THEN
316 p(lb1:ub1,lb2:ub2) = work(lb1:ub1,lb2:ub2)
317 DEALLOCATE (work)
318 END IF
319
320 END SUBROUTINE reallocate_i2
321! **************************************************************************************************
322!> \brief (Re)Allocate a 3D vector of type INTEGER with new dimensions (but same shape)
323!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
324!> \param lb1_new new lower bound for dimension 1
325!> \param ub1_new new upper bound for dimension 1
326!> \param lb2_new new lower bound for dimension 2
327!> \param ub2_new new upper bound for dimension 2
328!> \param lb3_new new lower bound for dimension 3
329!> \param ub3_new new upper bound for dimension 3
330! **************************************************************************************************
331 SUBROUTINE reallocate_i3 (p, lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new)
332 INTEGER, &
333 DIMENSION(:,:,:), &
334 POINTER, INTENT(INOUT) :: p
335
336 INTEGER, INTENT(IN) :: &
337 lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new
338
339 INTEGER :: lb1, lb1_old, ub1, ub1_old
340 INTEGER :: lb2, lb2_old, ub2, ub2_old
341 INTEGER :: lb3, lb3_old, ub3, ub3_old
342
343 INTEGER, &
344 DIMENSION(:,:,:), &
345 POINTER :: work
346
347 NULLIFY (work)
348
349 IF (ASSOCIATED(p)) THEN
350 lb1_old = lbound(p, 1)
351 ub1_old = ubound(p, 1)
352 lb1 = max(lb1_new, lb1_old)
353 ub1 = min(ub1_new, ub1_old)
354 lb2_old = lbound(p, 2)
355 ub2_old = ubound(p, 2)
356 lb2 = max(lb2_new, lb2_old)
357 ub2 = min(ub2_new, ub2_old)
358 lb3_old = lbound(p, 3)
359 ub3_old = ubound(p, 3)
360 lb3 = max(lb3_new, lb3_old)
361 ub3 = min(ub3_new, ub3_old)
362 work => p
363 END IF
364
365 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new,lb3_new:ub3_new))
366 p = 0
367
368 IF (ASSOCIATED(work)) THEN
369 p(lb1:ub1,lb2:ub2,lb3:ub3) = work(lb1:ub1,lb2:ub2,lb3:ub3)
370 DEALLOCATE (work)
371 END IF
372
373 END SUBROUTINE reallocate_i3
374! **************************************************************************************************
375!> \brief (Re)Allocate a 4D vector of type INTEGER with new dimensions (but same shape)
376!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
377!> \param lb1_new new lower bound for dimension 1
378!> \param ub1_new new upper bound for dimension 1
379!> \param lb2_new new lower bound for dimension 2
380!> \param ub2_new new upper bound for dimension 2
381!> \param lb3_new new lower bound for dimension 3
382!> \param ub3_new new upper bound for dimension 3
383!> \param lb4_new new lower bound for dimension 4
384!> \param ub4_new new upper bound for dimension 4
385! **************************************************************************************************
386 SUBROUTINE reallocate_i4 (p, lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new)
387 INTEGER, &
388 DIMENSION(:,:,:,:), &
389 POINTER, INTENT(INOUT) :: p
390
391 INTEGER, INTENT(IN) :: &
392 lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new
393
394 INTEGER :: lb1, lb1_old, ub1, ub1_old
395 INTEGER :: lb2, lb2_old, ub2, ub2_old
396 INTEGER :: lb3, lb3_old, ub3, ub3_old
397 INTEGER :: lb4, lb4_old, ub4, ub4_old
398
399 INTEGER, &
400 DIMENSION(:,:,:,:), &
401 POINTER :: work
402
403 NULLIFY (work)
404
405 IF (ASSOCIATED(p)) THEN
406 lb1_old = lbound(p, 1)
407 ub1_old = ubound(p, 1)
408 lb1 = max(lb1_new, lb1_old)
409 ub1 = min(ub1_new, ub1_old)
410 lb2_old = lbound(p, 2)
411 ub2_old = ubound(p, 2)
412 lb2 = max(lb2_new, lb2_old)
413 ub2 = min(ub2_new, ub2_old)
414 lb3_old = lbound(p, 3)
415 ub3_old = ubound(p, 3)
416 lb3 = max(lb3_new, lb3_old)
417 ub3 = min(ub3_new, ub3_old)
418 lb4_old = lbound(p, 4)
419 ub4_old = ubound(p, 4)
420 lb4 = max(lb4_new, lb4_old)
421 ub4 = min(ub4_new, ub4_old)
422 work => p
423 END IF
424
425 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new,lb3_new:ub3_new,lb4_new:ub4_new))
426 p = 0
427
428 IF (ASSOCIATED(work)) THEN
429 p(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4) = work(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4)
430 DEALLOCATE (work)
431 END IF
432
433 END SUBROUTINE reallocate_i4
434! **************************************************************************************************
435!> \brief (Re)Allocate a 1D vector of type INTEGER(KIND=int_8) with new dimensions (but same shape)
436!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
437!> \param lb1_new new lower bound for dimension 1
438!> \param ub1_new new upper bound for dimension 1
439! **************************************************************************************************
440 SUBROUTINE reallocate_8i1 (p, lb1_new,ub1_new)
441 INTEGER(KIND=int_8), &
442 DIMENSION(:), &
443 POINTER, INTENT(INOUT) :: p
444
445 INTEGER, INTENT(IN) :: &
446 lb1_new,ub1_new
447
448 INTEGER :: lb1, lb1_old, ub1, ub1_old
449
450 INTEGER(KIND=int_8), &
451 DIMENSION(:), &
452 POINTER :: work
453
454 NULLIFY (work)
455
456 IF (ASSOCIATED(p)) THEN
457 lb1_old = lbound(p, 1)
458 ub1_old = ubound(p, 1)
459 lb1 = max(lb1_new, lb1_old)
460 ub1 = min(ub1_new, ub1_old)
461 work => p
462 END IF
463
464 ALLOCATE (p(lb1_new:ub1_new))
465 p = 0
466
467 IF (ASSOCIATED(work)) THEN
468 p(lb1:ub1) = work(lb1:ub1)
469 DEALLOCATE (work)
470 END IF
471
472 END SUBROUTINE reallocate_8i1
473! **************************************************************************************************
474!> \brief (Re)Allocate a 2D vector of type INTEGER(KIND=int_8) with new dimensions (but same shape)
475!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
476!> \param lb1_new new lower bound for dimension 1
477!> \param ub1_new new upper bound for dimension 1
478!> \param lb2_new new lower bound for dimension 2
479!> \param ub2_new new upper bound for dimension 2
480! **************************************************************************************************
481 SUBROUTINE reallocate_8i2 (p, lb1_new,ub1_new,lb2_new,ub2_new)
482 INTEGER(KIND=int_8), &
483 DIMENSION(:,:), &
484 POINTER, INTENT(INOUT) :: p
485
486 INTEGER, INTENT(IN) :: &
487 lb1_new,ub1_new,lb2_new,ub2_new
488
489 INTEGER :: lb1, lb1_old, ub1, ub1_old
490 INTEGER :: lb2, lb2_old, ub2, ub2_old
491
492 INTEGER(KIND=int_8), &
493 DIMENSION(:,:), &
494 POINTER :: work
495
496 NULLIFY (work)
497
498 IF (ASSOCIATED(p)) THEN
499 lb1_old = lbound(p, 1)
500 ub1_old = ubound(p, 1)
501 lb1 = max(lb1_new, lb1_old)
502 ub1 = min(ub1_new, ub1_old)
503 lb2_old = lbound(p, 2)
504 ub2_old = ubound(p, 2)
505 lb2 = max(lb2_new, lb2_old)
506 ub2 = min(ub2_new, ub2_old)
507 work => p
508 END IF
509
510 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new))
511 p = 0
512
513 IF (ASSOCIATED(work)) THEN
514 p(lb1:ub1,lb2:ub2) = work(lb1:ub1,lb2:ub2)
515 DEALLOCATE (work)
516 END IF
517
518 END SUBROUTINE reallocate_8i2
519! **************************************************************************************************
520!> \brief (Re)Allocate a 1D vector of type REAL(KIND=dp) with new dimensions (but same shape)
521!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
522!> \param lb1_new new lower bound for dimension 1
523!> \param ub1_new new upper bound for dimension 1
524! **************************************************************************************************
525 SUBROUTINE reallocate_r1 (p, lb1_new,ub1_new)
526 REAL(KIND=dp), &
527 DIMENSION(:), &
528 POINTER, INTENT(INOUT) :: p
529
530 INTEGER, INTENT(IN) :: &
531 lb1_new,ub1_new
532
533 INTEGER :: lb1, lb1_old, ub1, ub1_old
534
535 REAL(KIND=dp), &
536 DIMENSION(:), &
537 POINTER :: work
538
539 NULLIFY (work)
540
541 IF (ASSOCIATED(p)) THEN
542 lb1_old = lbound(p, 1)
543 ub1_old = ubound(p, 1)
544 lb1 = max(lb1_new, lb1_old)
545 ub1 = min(ub1_new, ub1_old)
546 work => p
547 END IF
548
549 ALLOCATE (p(lb1_new:ub1_new))
550 p = 0.0_dp
551
552 IF (ASSOCIATED(work)) THEN
553 p(lb1:ub1) = work(lb1:ub1)
554 DEALLOCATE (work)
555 END IF
556
557 END SUBROUTINE reallocate_r1
558! **************************************************************************************************
559!> \brief (Re)Allocate a 2D vector of type REAL(KIND=dp) with new dimensions (but same shape)
560!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
561!> \param lb1_new new lower bound for dimension 1
562!> \param ub1_new new upper bound for dimension 1
563!> \param lb2_new new lower bound for dimension 2
564!> \param ub2_new new upper bound for dimension 2
565! **************************************************************************************************
566 SUBROUTINE reallocate_r2 (p, lb1_new,ub1_new,lb2_new,ub2_new)
567 REAL(KIND=dp), &
568 DIMENSION(:,:), &
569 POINTER, INTENT(INOUT) :: p
570
571 INTEGER, INTENT(IN) :: &
572 lb1_new,ub1_new,lb2_new,ub2_new
573
574 INTEGER :: lb1, lb1_old, ub1, ub1_old
575 INTEGER :: lb2, lb2_old, ub2, ub2_old
576
577 REAL(KIND=dp), &
578 DIMENSION(:,:), &
579 POINTER :: work
580
581 NULLIFY (work)
582
583 IF (ASSOCIATED(p)) THEN
584 lb1_old = lbound(p, 1)
585 ub1_old = ubound(p, 1)
586 lb1 = max(lb1_new, lb1_old)
587 ub1 = min(ub1_new, ub1_old)
588 lb2_old = lbound(p, 2)
589 ub2_old = ubound(p, 2)
590 lb2 = max(lb2_new, lb2_old)
591 ub2 = min(ub2_new, ub2_old)
592 work => p
593 END IF
594
595 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new))
596 p = 0.0_dp
597
598 IF (ASSOCIATED(work)) THEN
599 p(lb1:ub1,lb2:ub2) = work(lb1:ub1,lb2:ub2)
600 DEALLOCATE (work)
601 END IF
602
603 END SUBROUTINE reallocate_r2
604! **************************************************************************************************
605!> \brief (Re)Allocate a 3D vector of type REAL(KIND=dp) with new dimensions (but same shape)
606!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
607!> \param lb1_new new lower bound for dimension 1
608!> \param ub1_new new upper bound for dimension 1
609!> \param lb2_new new lower bound for dimension 2
610!> \param ub2_new new upper bound for dimension 2
611!> \param lb3_new new lower bound for dimension 3
612!> \param ub3_new new upper bound for dimension 3
613! **************************************************************************************************
614 SUBROUTINE reallocate_r3 (p, lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new)
615 REAL(KIND=dp), &
616 DIMENSION(:,:,:), &
617 POINTER, INTENT(INOUT) :: p
618
619 INTEGER, INTENT(IN) :: &
620 lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new
621
622 INTEGER :: lb1, lb1_old, ub1, ub1_old
623 INTEGER :: lb2, lb2_old, ub2, ub2_old
624 INTEGER :: lb3, lb3_old, ub3, ub3_old
625
626 REAL(KIND=dp), &
627 DIMENSION(:,:,:), &
628 POINTER :: work
629
630 NULLIFY (work)
631
632 IF (ASSOCIATED(p)) THEN
633 lb1_old = lbound(p, 1)
634 ub1_old = ubound(p, 1)
635 lb1 = max(lb1_new, lb1_old)
636 ub1 = min(ub1_new, ub1_old)
637 lb2_old = lbound(p, 2)
638 ub2_old = ubound(p, 2)
639 lb2 = max(lb2_new, lb2_old)
640 ub2 = min(ub2_new, ub2_old)
641 lb3_old = lbound(p, 3)
642 ub3_old = ubound(p, 3)
643 lb3 = max(lb3_new, lb3_old)
644 ub3 = min(ub3_new, ub3_old)
645 work => p
646 END IF
647
648 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new,lb3_new:ub3_new))
649 p = 0.0_dp
650
651 IF (ASSOCIATED(work)) THEN
652 p(lb1:ub1,lb2:ub2,lb3:ub3) = work(lb1:ub1,lb2:ub2,lb3:ub3)
653 DEALLOCATE (work)
654 END IF
655
656 END SUBROUTINE reallocate_r3
657! **************************************************************************************************
658!> \brief (Re)Allocate a 4D vector of type REAL(KIND=dp) with new dimensions (but same shape)
659!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
660!> \param lb1_new new lower bound for dimension 1
661!> \param ub1_new new upper bound for dimension 1
662!> \param lb2_new new lower bound for dimension 2
663!> \param ub2_new new upper bound for dimension 2
664!> \param lb3_new new lower bound for dimension 3
665!> \param ub3_new new upper bound for dimension 3
666!> \param lb4_new new lower bound for dimension 4
667!> \param ub4_new new upper bound for dimension 4
668! **************************************************************************************************
669 SUBROUTINE reallocate_r4 (p, lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new)
670 REAL(KIND=dp), &
671 DIMENSION(:,:,:,:), &
672 POINTER, INTENT(INOUT) :: p
673
674 INTEGER, INTENT(IN) :: &
675 lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new
676
677 INTEGER :: lb1, lb1_old, ub1, ub1_old
678 INTEGER :: lb2, lb2_old, ub2, ub2_old
679 INTEGER :: lb3, lb3_old, ub3, ub3_old
680 INTEGER :: lb4, lb4_old, ub4, ub4_old
681
682 REAL(KIND=dp), &
683 DIMENSION(:,:,:,:), &
684 POINTER :: work
685
686 NULLIFY (work)
687
688 IF (ASSOCIATED(p)) THEN
689 lb1_old = lbound(p, 1)
690 ub1_old = ubound(p, 1)
691 lb1 = max(lb1_new, lb1_old)
692 ub1 = min(ub1_new, ub1_old)
693 lb2_old = lbound(p, 2)
694 ub2_old = ubound(p, 2)
695 lb2 = max(lb2_new, lb2_old)
696 ub2 = min(ub2_new, ub2_old)
697 lb3_old = lbound(p, 3)
698 ub3_old = ubound(p, 3)
699 lb3 = max(lb3_new, lb3_old)
700 ub3 = min(ub3_new, ub3_old)
701 lb4_old = lbound(p, 4)
702 ub4_old = ubound(p, 4)
703 lb4 = max(lb4_new, lb4_old)
704 ub4 = min(ub4_new, ub4_old)
705 work => p
706 END IF
707
708 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new,lb3_new:ub3_new,lb4_new:ub4_new))
709 p = 0.0_dp
710
711 IF (ASSOCIATED(work)) THEN
712 p(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4) = work(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4)
713 DEALLOCATE (work)
714 END IF
715
716 END SUBROUTINE reallocate_r4
717! **************************************************************************************************
718!> \brief (Re)Allocate a 5D vector of type REAL(KIND=dp) with new dimensions (but same shape)
719!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
720!> \param lb1_new new lower bound for dimension 1
721!> \param ub1_new new upper bound for dimension 1
722!> \param lb2_new new lower bound for dimension 2
723!> \param ub2_new new upper bound for dimension 2
724!> \param lb3_new new lower bound for dimension 3
725!> \param ub3_new new upper bound for dimension 3
726!> \param lb4_new new lower bound for dimension 4
727!> \param ub4_new new upper bound for dimension 4
728!> \param lb5_new new lower bound for dimension 5
729!> \param ub5_new new upper bound for dimension 5
730! **************************************************************************************************
731 SUBROUTINE reallocate_r5 (p, lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new,lb5_new,ub5_new)
732 REAL(KIND=dp), &
733 DIMENSION(:,:,:,:,:), &
734 POINTER, INTENT(INOUT) :: p
735
736 INTEGER, INTENT(IN) :: &
737 lb1_new,ub1_new,lb2_new,ub2_new,lb3_new,ub3_new,lb4_new,ub4_new,lb5_new,ub5_new
738
739 INTEGER :: lb1, lb1_old, ub1, ub1_old
740 INTEGER :: lb2, lb2_old, ub2, ub2_old
741 INTEGER :: lb3, lb3_old, ub3, ub3_old
742 INTEGER :: lb4, lb4_old, ub4, ub4_old
743 INTEGER :: lb5, lb5_old, ub5, ub5_old
744
745 REAL(KIND=dp), &
746 DIMENSION(:,:,:,:,:), &
747 POINTER :: work
748
749 NULLIFY (work)
750
751 IF (ASSOCIATED(p)) THEN
752 lb1_old = lbound(p, 1)
753 ub1_old = ubound(p, 1)
754 lb1 = max(lb1_new, lb1_old)
755 ub1 = min(ub1_new, ub1_old)
756 lb2_old = lbound(p, 2)
757 ub2_old = ubound(p, 2)
758 lb2 = max(lb2_new, lb2_old)
759 ub2 = min(ub2_new, ub2_old)
760 lb3_old = lbound(p, 3)
761 ub3_old = ubound(p, 3)
762 lb3 = max(lb3_new, lb3_old)
763 ub3 = min(ub3_new, ub3_old)
764 lb4_old = lbound(p, 4)
765 ub4_old = ubound(p, 4)
766 lb4 = max(lb4_new, lb4_old)
767 ub4 = min(ub4_new, ub4_old)
768 lb5_old = lbound(p, 5)
769 ub5_old = ubound(p, 5)
770 lb5 = max(lb5_new, lb5_old)
771 ub5 = min(ub5_new, ub5_old)
772 work => p
773 END IF
774
775 ALLOCATE (p(lb1_new:ub1_new,lb2_new:ub2_new,lb3_new:ub3_new,lb4_new:ub4_new,lb5_new:ub5_new))
776 p = 0.0_dp
777
778 IF (ASSOCIATED(work)) THEN
779 p(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4,lb5:ub5) = work(lb1:ub1,lb2:ub2,lb3:ub3,lb4:ub4,lb5:ub5)
780 DEALLOCATE (work)
781 END IF
782
783 END SUBROUTINE reallocate_r5
784! **************************************************************************************************
785!> \brief (Re)Allocate a 1D vector of type LOGICAL with new dimensions (but same shape)
786!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
787!> \param lb1_new new lower bound for dimension 1
788!> \param ub1_new new upper bound for dimension 1
789! **************************************************************************************************
790 SUBROUTINE reallocate_l1 (p, lb1_new,ub1_new)
791 LOGICAL, &
792 DIMENSION(:), &
793 POINTER, INTENT(INOUT) :: p
794
795 INTEGER, INTENT(IN) :: &
796 lb1_new,ub1_new
797
798 INTEGER :: lb1, lb1_old, ub1, ub1_old
799
800 LOGICAL, &
801 DIMENSION(:), &
802 POINTER :: work
803
804 NULLIFY (work)
805
806 IF (ASSOCIATED(p)) THEN
807 lb1_old = lbound(p, 1)
808 ub1_old = ubound(p, 1)
809 lb1 = max(lb1_new, lb1_old)
810 ub1 = min(ub1_new, ub1_old)
811 work => p
812 END IF
813
814 ALLOCATE (p(lb1_new:ub1_new))
815 p = .false.
816
817 IF (ASSOCIATED(work)) THEN
818 p(lb1:ub1) = work(lb1:ub1)
819 DEALLOCATE (work)
820 END IF
821
822 END SUBROUTINE reallocate_l1
823! **************************************************************************************************
824!> \brief (Re)Allocate a 1D vector of type CHARACTER(LEN=*) with new dimensions (but same shape)
825!> \param p pointer to the existing data, if NULL() calling this is equivalent to an ALLOCATE(...)
826!> \param lb1_new new lower bound for dimension 1
827!> \param ub1_new new upper bound for dimension 1
828! **************************************************************************************************
829 SUBROUTINE reallocate_s1 (p, lb1_new,ub1_new)
830 CHARACTER(LEN=*), &
831 DIMENSION(:), &
832 POINTER, INTENT(INOUT) :: p
833
834 INTEGER, INTENT(IN) :: &
835 lb1_new,ub1_new
836
837 INTEGER :: lb1, lb1_old, ub1, ub1_old
838
839 CHARACTER(LEN=LEN(p)), &
840 DIMENSION(:), &
841 POINTER :: work
842
843 NULLIFY (work)
844
845 IF (ASSOCIATED(p)) THEN
846 lb1_old = lbound(p, 1)
847 ub1_old = ubound(p, 1)
848 lb1 = max(lb1_new, lb1_old)
849 ub1 = min(ub1_new, ub1_old)
850 work => p
851 END IF
852
853 ALLOCATE (p(lb1_new:ub1_new))
854 p = ""
855
856 IF (ASSOCIATED(work)) THEN
857 p(lb1:ub1) = work(lb1:ub1)
858 DEALLOCATE (work)
859 END IF
860
861 END SUBROUTINE reallocate_s1
862
863END MODULE memory_utilities
memory_utilities::reallocate
Definition memory_utilities.F:27
kinds
Defines the basic variable types.
Definition kinds.F:23
kinds::int_8
integer, parameter, public int_8
Definition kinds.F:54
kinds::dp
integer, parameter, public dp
Definition kinds.F:34
memory_utilities
Utility routines for the memory handling.
Definition memory_utilities.F:14