QR_MUMPS
 All Classes Files Functions Variables Enumerations Enumerator Pages
qrm_mem_mod.F90
Go to the documentation of this file.
1 !! ##############################################################################################
2 !!
3 !! Copyright 2012 CNRS, INPT
4 !!
5 !! This file is part of qr_mumps.
6 !!
7 !! qr_mumps is free software: you can redistribute it and/or modify
8 !! it under the terms of the GNU Lesser General Public License as
9 !! published by the Free Software Foundation, either version 3 of
10 !! the License, or (at your option) any later version.
11 !!
12 !! qr_mumps is distributed in the hope that it will be useful,
13 !! but WITHOUT ANY WARRANTY; without even the implied warranty of
14 !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 !! GNU Lesser General Public License for more details.
16 !!
17 !! You can find a copy of the GNU Lesser General Public License
18 !! in the qr_mumps/doc directory.
19 !!
20 !! ##############################################################################################
21 
22 
23 !! ##############################################################################################
33 
34 
37 
39 
40  use qrm_error_mod
41  use qrm_const_mod
42  implicit none
43 
51 
57  interface qrm_palloc
58  module procedure qrm_palloc_i, qrm_palloc_2i, qrm_palloc_i_8
59  module procedure qrm_palloc_s, qrm_palloc_2s, qrm_palloc_s_8
60  module procedure qrm_palloc_d, qrm_palloc_2d, qrm_palloc_d_8
61  module procedure qrm_palloc_c, qrm_palloc_2c, qrm_palloc_c_8
62  module procedure qrm_palloc_z, qrm_palloc_2z, qrm_palloc_z_8
63  end interface
64 
72 
78  interface qrm_aalloc
79  module procedure qrm_aalloc_i, qrm_aalloc_2i
80  module procedure qrm_aalloc_s, qrm_aalloc_2s, qrm_aalloc_3s
81  module procedure qrm_aalloc_d, qrm_aalloc_2d, qrm_aalloc_3d
82  module procedure qrm_aalloc_c, qrm_aalloc_2c, qrm_aalloc_3c
83  module procedure qrm_aalloc_z, qrm_aalloc_2z, qrm_aalloc_3z
84  end interface
85 
93 
98  interface qrm_pdealloc
99  module procedure qrm_pdealloc_i, qrm_pdealloc_2i
100  module procedure qrm_pdealloc_s, qrm_pdealloc_2s
101  module procedure qrm_pdealloc_d, qrm_pdealloc_2d
102  module procedure qrm_pdealloc_c, qrm_pdealloc_2c
103  module procedure qrm_pdealloc_z, qrm_pdealloc_2z
104  end interface
105 
113 
118  interface qrm_adealloc
119  module procedure qrm_adealloc_i, qrm_adealloc_2i
124  end interface
125 
132 
137  interface qrm_prealloc
138  module procedure qrm_prealloc_i
139  module procedure qrm_prealloc_s
140  module procedure qrm_prealloc_d
141  module procedure qrm_prealloc_c
142  module procedure qrm_prealloc_z
143  end interface
144 
151 
156  interface qrm_arealloc
157  module procedure qrm_arealloc_i
158  module procedure qrm_arealloc_s
159  module procedure qrm_arealloc_d
160  module procedure qrm_arealloc_c
161  module procedure qrm_arealloc_z
162  end interface
163 
170 
175  interface qrm_asize
176  module procedure qrm_asize_i
177  module procedure qrm_asize_s, qrm_asize_2s, qrm_asize_3s
178  module procedure qrm_asize_d, qrm_asize_2d, qrm_asize_3d
179  module procedure qrm_asize_c, qrm_asize_2c, qrm_asize_3c
180  module procedure qrm_asize_z, qrm_asize_2z, qrm_asize_3z
181  end interface
182 
189 
194  interface qrm_psize
195  module procedure qrm_psize_i
196  module procedure qrm_psize_s
197  module procedure qrm_psize_d
198  module procedure qrm_psize_c
199  module procedure qrm_psize_z
200  end interface
201 
202  integer :: qrm_mem_thn=0, qrm_mem_nth=1
203  !$omp threadprivate(qrm_mem_thn)
204 
206  integer(kind=8) :: qrm_tot_mem(0:qrm_maxthreads-1)=0
207 
209  integer(kind=8) :: qrm_max_mem(0:qrm_maxthreads-1)=0
210 
213  integer(kind=8) :: qrm_seq_peak=0
214 
215  integer :: qrm_exact_mem = qrm_no_
216 
217  integer(kind=8), parameter :: qrm_sizeof_i_=4
218  integer(kind=8), parameter :: qrm_sizeof_s_=4
219  integer(kind=8), parameter :: qrm_sizeof_d_=8
220  integer(kind=8), parameter :: qrm_sizeof_c_=8
221  integer(kind=8), parameter :: qrm_sizeof_z_=16
222 
223 
224 #if defined(memlim)
225  integer(kind=8) :: qrm_mem_lim=500000000
226 #endif
227 
228 contains
229 
235  subroutine qrm_par_mem_init()
236  !$ use omp_lib
237  if(qrm_exact_mem .eq. qrm_yes_) then
238  ! do nothing
239  else
240  !$ qrm_mem_thn = omp_get_thread_num()
241  !$omp master
242  !$ qrm_mem_nth = omp_get_num_threads()
243  qrm_seq_peak = qrm_max_mem(0)
244  qrm_tot_mem(1:qrm_mem_nth-1)=0
245  qrm_max_mem(0:qrm_mem_nth-1)=0
246  !$omp end master
247  !$omp barrier
248  end if
249  return
250  end subroutine qrm_par_mem_init
251 
252  subroutine qrm_par_mem_finalize()
253  if(qrm_exact_mem .eq. qrm_yes_) then
254  ! do nothing
255  else
256  !$omp barrier
257  !$omp master
258  qrm_tot_mem(0) = sum(qrm_tot_mem(0:qrm_mem_nth-1))
259  qrm_max_mem(0) = max(sum(qrm_max_mem(0:qrm_mem_nth-1)), &
260  & qrm_seq_peak)
261  qrm_seq_peak=0
262  qrm_tot_mem(1:qrm_mem_nth-1)=0
263  qrm_max_mem(1:qrm_mem_nth-1)=0
264  !$omp end master
265  end if
266  return
267  end subroutine qrm_par_mem_finalize
268 
273  subroutine qrm_mem_upd(n)
274  integer(kind=8) :: n
275  if(qrm_exact_mem .eq. qrm_yes_) then
276  !$omp critical(mem)
277  qrm_tot_mem(0) = qrm_tot_mem(0)+n
278  if(qrm_tot_mem(0) .gt. qrm_max_mem(0)) &
279  & qrm_max_mem(0) = qrm_tot_mem(0)
280  !$omp end critical(mem)
281  else
282  qrm_tot_mem(qrm_mem_thn) = qrm_tot_mem(qrm_mem_thn)+n
283  if(qrm_tot_mem(qrm_mem_thn) .gt. qrm_max_mem(qrm_mem_thn)) &
284  & qrm_max_mem(qrm_mem_thn) = qrm_tot_mem(qrm_mem_thn)
285  end if
286  return
287  end subroutine qrm_mem_upd
288 
289 
290 
298  subroutine qrm_palloc_d(a, n, info)
299 
300  real(kind(1.d0)), pointer, dimension(:) :: a
301  integer, intent(in) :: n
302  integer, optional :: info
303 
304  integer :: err, disp
305 
306  if(associated(a)) then
307  call qrm_err_push(4,sub='qrm_palloc_d')
308  else
309 #if defined(memlim)
310  !$omp critical(mem)
311  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
312  !$omp end critical(mem)
313  if( n*qrm_sizeof_d_ .gt. disp ) then
314  err = 1
315  else
316  allocate(a(n), stat=err)
317  end if
318 #else
319  allocate(a(n), stat=err)
320 #endif
321  if(err .ne. 0) then
322  if(present(info)) then
323  info = err
324  else
325  call qrm_err_push(5,sub='qrm_palloc_d',ied=(/n,0,0,0,0/))
326  end if
327  else
328  call qrm_mem_upd(int(n,8)*qrm_sizeof_d_)
329  end if
330  end if
331 
332  return
333 
334  end subroutine qrm_palloc_d
335 
343  subroutine qrm_palloc_d_8(a, n, info)
344 
345  real(kind(1.d0)), pointer, dimension(:) :: a
346  integer(kind=8), intent(in) :: n
347  integer, optional :: info
348 
349  integer :: err, disp
350 
351  if(associated(a)) then
352  call qrm_err_push(4,sub='qrm_palloc_d')
353  else
354 #if defined(memlim)
355  !$omp critical(mem)
356  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
357  !$omp end critical(mem)
358  if( n*qrm_sizeof_d_ .gt. disp ) then
359  err = 1
360  else
361  allocate(a(n), stat=err)
362  end if
363 #else
364  allocate(a(n), stat=err)
365 #endif
366  if(err .ne. 0) then
367  if(present(info)) then
368  info = err
369  else
370  call qrm_err_push(5,sub='qrm_palloc_d',ied=(/int(n,4),0,0,0,0/))
371  end if
372  else
373  call qrm_mem_upd(int(n,8)*qrm_sizeof_d_)
374  end if
375  end if
376 
377  return
378 
379  end subroutine qrm_palloc_d_8
380 
388  subroutine qrm_palloc_s(a, n, info)
389 
390  real(kind(1.e0)), pointer, dimension(:) :: a
391  integer, intent(in) :: n
392  integer, optional :: info
393 
394  integer :: err, disp
395 
396  if(n .lt. 0) return
397 
398  if(associated(a)) then
399  call qrm_err_push(4,sub='qrm_palloc_s')
400  else
401 #if defined(memlim)
402  !$omp critical(mem)
403  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1)
404  !$omp end critical(mem)
405  if( n*qrm_sizeof_s_ .gt. disp ) then
406  err = 1
407  else
408  allocate(a(n), stat=err)
409  end if
410 #else
411  allocate(a(n), stat=err)
412 #endif
413  if(err .ne. 0) then
414  if(present(info)) then
415  info = err
416  else
417  call qrm_err_push(5,sub='qrm_palloc_s',ied=(/n,0,0,0,0/))
418  end if
419  else
420  call qrm_mem_upd(int(n,8)*qrm_sizeof_s_)
421  end if
422 
423  end if
424 
425  return
426 
427  end subroutine qrm_palloc_s
428 
436  subroutine qrm_palloc_s_8(a, n, info)
437 
438  real(kind(1.e0)), pointer, dimension(:) :: a
439  integer(kind=8), intent(in) :: n
440  integer, optional :: info
441 
442  integer :: err, disp
443 
444  if(n .lt. 0) return
445 
446  if(associated(a)) then
447  call qrm_err_push(4,sub='qrm_palloc_s')
448  else
449 #if defined(memlim)
450  !$omp critical(mem)
451  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1)
452  !$omp end critical(mem)
453  if( n*qrm_sizeof_s_ .gt. disp ) then
454  err = 1
455  else
456  allocate(a(n), stat=err)
457  end if
458 #else
459  allocate(a(n), stat=err)
460 #endif
461  if(err .ne. 0) then
462  if(present(info)) then
463  info = err
464  else
465  call qrm_err_push(5,sub='qrm_palloc_s',ied=(/int(n,4),0,0,0,0/))
466  end if
467  else
468  call qrm_mem_upd(int(n,8)*qrm_sizeof_s_)
469  end if
470 
471  end if
472 
473  return
474 
475  end subroutine qrm_palloc_s_8
476 
477 
485  subroutine qrm_palloc_i(a, n, info)
486 
487  integer, pointer, dimension(:) :: a
488  integer, intent(in) :: n
489  integer, optional :: info
490 
491  integer :: err, disp
492 
493  if(n .lt. 0) return
494 
495  if(associated(a)) then
496  call qrm_err_push(4,sub='qrm_palloc_i')
497  else
498 #if defined(memlim)
499  !$omp critical(mem)
500  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1)
501  !$omp end critical(mem)
502  if( n*qrm_sizeof_i_ .gt. disp ) then
503  err = 1
504  else
505  allocate(a(n), stat=err)
506  end if
507 #else
508  allocate(a(n), stat=err)
509 #endif
510  if(err .ne. 0) then
511  if(present(info)) then
512  info = err
513  else
514  call qrm_err_push(5,sub='qrm_palloc_i',ied=(/n,0,0,0,0/))
515  end if
516  else
517  call qrm_mem_upd(int(n,8)*qrm_sizeof_i_)
518  end if
519 
520  end if
521 
522  return
523 
524  end subroutine qrm_palloc_i
525 
533  subroutine qrm_palloc_i_8(a, n, info)
534 
535  integer, pointer, dimension(:) :: a
536  integer(kind=8), intent(in) :: n
537  integer, optional :: info
538 
539  integer :: err, disp
540 
541  if(n .lt. 0) return
542 
543  if(associated(a)) then
544  call qrm_err_push(4,sub='qrm_palloc_i')
545  else
546 #if defined(memlim)
547  !$omp critical(mem)
548  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1)
549  !$omp end critical(mem)
550  if( n*qrm_sizeof_i_ .gt. disp ) then
551  err = 1
552  else
553  allocate(a(n), stat=err)
554  end if
555 #else
556  allocate(a(n), stat=err)
557 #endif
558  if(err .ne. 0) then
559  if(present(info)) then
560  info = err
561  else
562  call qrm_err_push(5,sub='qrm_palloc_i',ied=(/int(n,4),0,0,0,0/))
563  end if
564  else
565  call qrm_mem_upd(int(n,8)*qrm_sizeof_i_)
566  end if
567 
568  end if
569 
570  return
571 
572  end subroutine qrm_palloc_i_8
573 
574 
575 
585  subroutine qrm_palloc_2d(a, m, n, info)
586 
587  real(kind(1.d0)), pointer, dimension(:,:) :: a
588  integer, intent(in) :: m, n
589  integer, optional :: info
590 
591  integer :: err, disp
592 
593  if(min(m,n) .lt. 0) return
594 
595  if(associated(a)) then
596  call qrm_err_push(4,sub='qrm_palloc_2d')
597  else
598 #if defined(memlim)
599  !$omp critical(mem)
600  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
601  !$omp end critical(mem)
602  if( n*m*qrm_sizeof_d_ .gt. disp ) then
603  err = 1
604  else
605  allocate(a(m,n), stat=err)
606  end if
607 #else
608  allocate(a(m,n), stat=err)
609 #endif
610  if(err .ne. 0) then
611  if(present(info)) then
612  info = err
613  else
614  call qrm_err_push(5,sub='qrm_palloc_2d',ied=(/m*n,0,0,0,0/))
615  end if
616  else
617  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_d_)
618  end if
619 
620  end if
621 
622  return
623 
624  end subroutine qrm_palloc_2d
625 
626 
636  subroutine qrm_palloc_2s(a, m, n, info)
637 
638  real(kind(1.e0)), pointer, dimension(:,:) :: a
639  integer, intent(in) :: m, n
640  integer, optional :: info
641 
642  integer :: err, disp
643 
644  if(min(m,n) .lt. 0) return
645 
646  if(associated(a)) then
647  call qrm_err_push(4,sub='qrm_palloc_2s')
648  else
649 #if defined(memlim)
650  !$omp critical(mem)
651  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
652  !$omp end critical(mem)
653  if( n*m*qrm_sizeof_s_ .gt. disp ) then
654  err = 1
655  else
656  allocate(a(m,n), stat=err)
657  end if
658 #else
659  allocate(a(m,n), stat=err)
660 #endif
661  if(err .ne. 0) then
662  if(present(info)) then
663  info = err
664  else
665  call qrm_err_push(5,sub='qrm_palloc_2s',ied=(/m*n,0,0,0,0/))
666  end if
667  else
668  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_s_)
669  end if
670 
671  end if
672 
673  return
674 
675  end subroutine qrm_palloc_2s
676 
677 
687  subroutine qrm_palloc_2i(a, m, n, info)
688 
689  integer, pointer, dimension(:,:) :: a
690  integer, intent(in) :: m, n
691  integer, optional :: info
692 
693  integer :: err, disp
694 
695  if(min(m,n) .lt. 0) return
696 
697  if(associated(a)) then
698  call qrm_err_push(4,sub='qrm_aalloc_2i')
699  else
700 #if defined(memlim)
701  !$omp critical(mem)
702  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
703  !$omp end critical(mem)
704  if( n*m*qrm_sizeof_i_ .gt. disp ) then
705  err = 1
706  else
707  allocate(a(m,n), stat=err)
708  end if
709 #else
710  allocate(a(m,n), stat=err)
711 #endif
712  if(err .ne. 0) then
713  if(present(info)) then
714  info = err
715  else
716  call qrm_err_push(5,sub='qrm_aalloc_2i',ied=(/m*n,0,0,0,0/))
717  end if
718  else
719  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_i_)
720  end if
721 
722  end if
723 
724  return
725 
726  end subroutine qrm_palloc_2i
727 
737  subroutine qrm_palloc_2z(a, m, n, info)
738 
739  complex(kind(1.d0)), pointer, dimension(:,:) :: a
740  integer, intent(in) :: m, n
741  integer, optional :: info
742 
743  integer :: err, disp
744 
745  if(min(m,n) .lt. 0) return
746 
747  if(associated(a)) then
748  call qrm_err_push(4,sub='qrm_palloc_2z')
749  else
750 #if defined(memlim)
751  !$omp critical(mem)
752  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
753  !$omp end critical(mem)
754  if( n*m*qrm_sizeof_z_ .gt. disp ) then
755  err = 1
756  else
757  allocate(a(m,n), stat=err)
758  end if
759 #else
760  allocate(a(m,n), stat=err)
761 #endif
762  if(err .ne. 0) then
763  if(present(info)) then
764  info = err
765  else
766  call qrm_err_push(5,sub='qrm_aalloc_2z',ied=(/m*n,0,0,0,0/))
767  end if
768  else
769  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_z_)
770  end if
771 
772  end if
773 
774  return
775 
776  end subroutine qrm_palloc_2z
777 
787  subroutine qrm_palloc_2c(a, m, n, info)
788 
789  complex(kind(1.e0)), pointer, dimension(:,:) :: a
790  integer, intent(in) :: m, n
791  integer, optional :: info
792 
793  integer :: err, disp
794 
795  if(min(m,n) .lt. 0) return
796 
797  if(associated(a)) then
798  call qrm_err_push(4,sub='qrm_palloc_2c')
799  else
800 #if defined(memlim)
801  !$omp critical(mem)
802  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
803  !$omp end critical(mem)
804  if( n*m*qrm_sizeof_c_ .gt. disp ) then
805  err = 1
806  else
807  allocate(a(m,n), stat=err)
808  end if
809 #else
810  allocate(a(m,n), stat=err)
811 #endif
812  if(err .ne. 0) then
813  if(present(info)) then
814  info = err
815  else
816  call qrm_err_push(5,sub='qrm_aalloc_2c',ied=(/n,0,0,0,0/))
817  end if
818  else
819  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_c_)
820  end if
821 
822  end if
823 
824  return
825 
826  end subroutine qrm_palloc_2c
827 
828 
829 
830 
831 
841  subroutine qrm_aalloc_d(a, n, lbnd, info)
842 
843  real(kind(1.d0)), allocatable, dimension(:) :: a
844  integer, intent(in) :: n
845  integer, optional :: lbnd
846  integer, optional :: info
847 
848  integer :: err, ilbnd, disp
849 
850  if(n .lt. 0) return
851 
852  if(allocated(a)) then
853  call qrm_err_push(4,sub='qrm_aalloc_d')
854  else
855  if(present(lbnd)) then
856  ilbnd = lbnd
857  else
858  ilbnd = 1
859  end if
860 
861 #if defined(memlim)
862  !$omp critical(mem)
863  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
864  !$omp end critical(mem)
865  if( n*qrm_sizeof_d_ .gt. disp ) then
866  err = 1
867  else
868  allocate(a(ilbnd: ilbnd+n-1), stat=err)
869  end if
870 #else
871  allocate(a(ilbnd: ilbnd+n-1), stat=err)
872 #endif
873  if(err .ne. 0) then
874  if(present(info)) then
875  info = err
876  else
877  call qrm_err_push(5,sub='qrm_aalloc_d',ied=(/n,0,0,0,0/))
878  end if
879  else
880  call qrm_mem_upd(int(n,8)*qrm_sizeof_d_)
881  end if
882 
883  end if
884 
885  return
886 
887  end subroutine qrm_aalloc_d
888 
889 
899  subroutine qrm_aalloc_s(a, n, lbnd, info)
900 
901  real(kind(1.e0)), allocatable, dimension(:) :: a
902  integer, intent(in) :: n
903  integer, optional :: lbnd
904  integer, optional :: info
905 
906  integer :: err, ilbnd, disp
907 
908  if(n .lt. 0) return
909  err = 0
910  if(allocated(a)) then
911  call qrm_err_push(4,sub='qrm_aalloc_s')
912  else
913  if(present(lbnd)) then
914  ilbnd = lbnd
915  else
916  ilbnd = 1
917  end if
918 
919 #if defined(memlim)
920  !$omp critical(mem)
921  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
922  !$omp end critical(mem)
923  if( n*qrm_sizeof_s_ .gt. disp ) then
924  err = 1
925  else
926  allocate(a(ilbnd: ilbnd+n-1), stat=err)
927  end if
928 #else
929  allocate(a(ilbnd: ilbnd+n-1), stat=err)
930 #endif
931  if(err .ne. 0) then
932  if(present(info)) then
933  info = err
934  else
935  call qrm_err_push(5,sub='qrm_aalloc_s',ied=(/n,0,0,0,0/))
936  end if
937  else
938  call qrm_mem_upd(int(n,8)*qrm_sizeof_s_)
939  end if
940 
941  end if
942 
943  return
944 
945  end subroutine qrm_aalloc_s
946 
947 
957  subroutine qrm_aalloc_i(a, n, lbnd, info)
958 
959  integer, allocatable, dimension(:) :: a
960  integer, intent(in) :: n
961  integer, optional :: lbnd
962  integer, optional :: info
963 
964  integer :: err, ilbnd, disp
965 
966  if(n .lt. 0) return
967 
968  if(allocated(a)) then
969  call qrm_err_push(4,sub='qrm_aalloc_i')
970  else
971  if(present(lbnd)) then
972  ilbnd = lbnd
973  else
974  ilbnd = 1
975  end if
976 
977 #if defined(memlim)
978  !$omp critical(mem)
979  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
980  !$omp end critical(mem)
981  if( n*qrm_sizeof_i_ .gt. disp ) then
982  err = 1
983  else
984  allocate(a(ilbnd: ilbnd+n-1), stat=err)
985  end if
986 #else
987  allocate(a(ilbnd: ilbnd+n-1), stat=err)
988 #endif
989  if(err .ne. 0) then
990  if(present(info)) then
991  info = err
992  else
993  call qrm_err_push(5,sub='qrm_aalloc_i',ied=(/n,0,0,0,0/))
994  end if
995  else
996  call qrm_mem_upd(int(n,8)*qrm_sizeof_i_)
997  end if
998 
999  end if
1000 
1001  return
1002 
1003  end subroutine qrm_aalloc_i
1004 
1005 
1015  subroutine qrm_aalloc_2d(a, m, n, info)
1016 
1017  real(kind(1.d0)), allocatable, dimension(:,:) :: a
1018  integer, intent(in) :: m, n
1019  integer, optional :: info
1020 
1021  integer :: err, disp
1022 
1023  if(min(m,n) .lt. 0) return
1024 
1025  if(allocated(a)) then
1026  call qrm_err_push(4,sub='qrm_aalloc_2d')
1027  else
1028 #if defined(memlim)
1029  !$omp critical(mem)
1030  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
1031  !$omp end critical(mem)
1032  if( n*m*qrm_sizeof_d_ .gt. disp ) then
1033  err = 1
1034  else
1035  allocate(a(m,n), stat=err)
1036  end if
1037 #else
1038  allocate(a(m,n), stat=err)
1039 #endif
1040  if(err .ne. 0) then
1041  if(present(info)) then
1042  info = err
1043  else
1044  call qrm_err_push(5,sub='qrm_aalloc_2d',ied=(/m*n,0,0,0,0/))
1045  end if
1046  else
1047  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_d_)
1048  end if
1049 
1050  end if
1051 
1052  return
1053 
1054  end subroutine qrm_aalloc_2d
1055 
1056 
1066  subroutine qrm_aalloc_2s(a, m, n, info)
1067 
1068  real(kind(1.e0)), allocatable, dimension(:,:) :: a
1069  integer, intent(in) :: m, n
1070  integer, optional :: info
1071 
1072  integer :: err, disp
1073 
1074  if(min(m,n) .lt. 0) return
1075 
1076  if(allocated(a)) then
1077  call qrm_err_push(4,sub='qrm_aalloc_2s')
1078  else
1079 #if defined(memlim)
1080  !$omp critical(mem)
1081  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
1082  !$omp end critical(mem)
1083  if( n*m*qrm_sizeof_s_ .gt. disp ) then
1084  err = 1
1085  else
1086  allocate(a(m,n), stat=err)
1087  end if
1088 #else
1089  allocate(a(m,n), stat=err)
1090 #endif
1091  if(err .ne. 0) then
1092  if(present(info)) then
1093  info = err
1094  else
1095  call qrm_err_push(5,sub='qrm_aalloc_2s',ied=(/m*n,0,0,0,0/))
1096  end if
1097  else
1098  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_s_)
1099  end if
1100 
1101  end if
1102 
1103  return
1104 
1105  end subroutine qrm_aalloc_2s
1106 
1107 
1117  subroutine qrm_aalloc_2i(a, m, n, info)
1118 
1119  integer, allocatable, dimension(:,:) :: a
1120  integer, intent(in) :: m, n
1121  integer, optional :: info
1122 
1123  integer :: err, disp
1124 
1125  if(min(m,n) .lt. 0) return
1126 
1127  if(allocated(a)) then
1128  call qrm_err_push(4,sub='qrm_aalloc_2i')
1129  else
1130 #if defined(memlim)
1131  !$omp critical(mem)
1132  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
1133  !$omp end critical(mem)
1134  if( n*m*qrm_sizeof_i_ .gt. disp ) then
1135  err = 1
1136  else
1137  allocate(a(m,n), stat=err)
1138  end if
1139 #else
1140  allocate(a(m,n), stat=err)
1141 #endif
1142  if(err .ne. 0) then
1143  if(present(info)) then
1144  info = err
1145  else
1146  call qrm_err_push(5,sub='qrm_aalloc_2i',ied=(/m*n,0,0,0,0/))
1147  end if
1148  else
1149  call qrm_mem_upd(int(m,8)*int(n,8)*qrm_sizeof_i_)
1150  end if
1151 
1152  end if
1153 
1154  return
1155 
1156  end subroutine qrm_aalloc_2i
1157 
1158 
1159 
1171  subroutine qrm_aalloc_3d(a, m, n, k, info)
1172 
1173  real(kind(1.d0)), allocatable, dimension(:,:,:) :: a
1174  integer, intent(in) :: m, n, k
1175  integer, optional :: info
1176 
1177  integer :: err, disp
1178 
1179  if(min(min(m,n),k) .lt. 0) return
1180 
1181  if(allocated(a)) then
1182  call qrm_err_push(4,sub='qrm_aalloc_3d')
1183  else
1184 #if defined(memlim)
1185  !$omp critical(mem)
1186  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
1187  !$omp end critical(mem)
1188  if( n*m*k*qrm_sizeof_d_ .gt. disp ) then
1189  err = 1
1190  else
1191  allocate(a(m,n,k), stat=err)
1192  end if
1193 #else
1194  allocate(a(m,n,k), stat=err)
1195 #endif
1196  if(err .ne. 0) then
1197  if(present(info)) then
1198  info = err
1199  else
1200  call qrm_err_push(5,sub='qrm_aalloc_3d',ied=(/m*n*k,0,0,0,0/))
1201  end if
1202  else
1203  call qrm_mem_upd(int(m,8)*int(n,8)*int(k,8)*qrm_sizeof_d_)
1204  end if
1205 
1206  end if
1207 
1208  return
1209 
1210  end subroutine qrm_aalloc_3d
1211 
1212 
1224  subroutine qrm_aalloc_3s(a, m, n, k, info)
1225 
1226  real(kind(1.e0)), allocatable, dimension(:,:,:) :: a
1227  integer, intent(in) :: m, n, k
1228  integer, optional :: info
1229 
1230  integer :: err, disp
1231 
1232  if(min(min(m,n),k) .lt. 0) return
1233 
1234  if(allocated(a)) then
1235  call qrm_err_push(4,sub='qrm_aalloc_3s')
1236  else
1237 #if defined(memlim)
1238  !$omp critical(mem)
1239  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
1240  !$omp end critical(mem)
1241  if( n*m*k*qrm_sizeof_s_ .gt. disp ) then
1242  err = 1
1243  else
1244  allocate(a(m,n,k), stat=err)
1245  end if
1246 #else
1247  allocate(a(m,n,k), stat=err)
1248 #endif
1249  if(err .ne. 0) then
1250  if(present(info)) then
1251  info = err
1252  else
1253  call qrm_err_push(5,sub='qrm_aalloc_3s',ied=(/n,0,0,0,0/))
1254  end if
1255  else
1256  call qrm_mem_upd(m*int(n,8)*int(k,8)*qrm_sizeof_s_)
1257  end if
1258 
1259  end if
1260 
1261  return
1262 
1263  end subroutine qrm_aalloc_3s
1264 
1265 
1266 
1269  subroutine qrm_pdealloc_d(a)
1270 
1271  real(kind(1.d0)), pointer, dimension(:) :: a
1272 
1273  integer :: err=0, n
1274 
1275  if(associated(a)) then
1276  n = size(a)
1277  deallocate(a, stat=err)
1278  else
1279  return
1280  end if
1281  if(err .ne. 0) then
1282  call qrm_err_push(7,sub='qrm_pdealloc_d',ied=(/err,0,0,0,0/))
1283  else
1284  call qrm_mem_upd(-int(n,8)*qrm_sizeof_d_)
1285  end if
1286 
1287  return
1288 
1289  end subroutine qrm_pdealloc_d
1290 
1293  subroutine qrm_pdealloc_s(a)
1294 
1295  real(kind(1.e0)), pointer, dimension(:) :: a
1296 
1297  integer :: err=0, n
1298 
1299  if(associated(a)) then
1300  n = size(a)
1301  deallocate(a, stat=err)
1302  else
1303  return
1304  end if
1305  if(err .ne. 0) then
1306  call qrm_err_push(7,sub='qrm_pdealloc_s',ied=(/err,0,0,0,0/))
1307  else
1308  call qrm_mem_upd(-int(n,8)*qrm_sizeof_s_)
1309  end if
1310 
1311  return
1312 
1313  end subroutine qrm_pdealloc_s
1314 
1317  subroutine qrm_pdealloc_2d(a)
1318 
1319  real(kind(1.d0)), pointer, dimension(:,:) :: a
1320 
1321  integer :: err=0, n, m
1322 
1323  if(associated(a)) then
1324  m = size(a,1)
1325  n = size(a,2)
1326  deallocate(a, stat=err)
1327  else
1328  return
1329  end if
1330  if(err .ne. 0) then
1331  call qrm_err_push(7,sub='qrm_pdealloc_2d',ied=(/err,0,0,0,0/))
1332  else
1333  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_d_)
1334  end if
1335 
1336  return
1337 
1338  end subroutine qrm_pdealloc_2d
1339 
1342  subroutine qrm_pdealloc_2s(a)
1343 
1344  real(kind(1.e0)), pointer, dimension(:,:) :: a
1345 
1346  integer :: err=0, n, m
1347 
1348  if(associated(a)) then
1349  m = size(a,1)
1350  n = size(a,2)
1351  deallocate(a, stat=err)
1352  else
1353  return
1354  end if
1355  if(err .ne. 0) then
1356  call qrm_err_push(7,sub='qrm_pdealloc_2s',ied=(/err,0,0,0,0/))
1357  else
1358  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_s_)
1359  end if
1360 
1361  return
1362 
1363  end subroutine qrm_pdealloc_2s
1364 
1367  subroutine qrm_pdealloc_i(a)
1368 
1369  integer, pointer, dimension(:) :: a
1370 
1371  integer :: err=0, n
1372 
1373  if(associated(a)) then
1374  n=size(a)
1375  deallocate(a, stat=err)
1376  else
1377  return
1378  end if
1379  if(err .ne. 0) then
1380  call qrm_err_push(7,sub='qrm_pdealloc_i',ied=(/err,0,0,0,0/))
1381  else
1382  call qrm_mem_upd(-int(n,8)*qrm_sizeof_i_)
1383  end if
1384 
1385  return
1386 
1387  end subroutine qrm_pdealloc_i
1388 
1389 
1392  subroutine qrm_pdealloc_2i(a)
1393 
1394  integer, pointer, dimension(:,:) :: a
1395 
1396  integer :: err=0, n, m
1397 
1398  if(associated(a)) then
1399  m = size(a,1)
1400  n = size(a,2)
1401  deallocate(a, stat=err)
1402  else
1403  return
1404  end if
1405  if(err .ne. 0) then
1406  call qrm_err_push(7,sub='qrm_pdealloc_2i',ied=(/err,0,0,0,0/))
1407  else
1408  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_i_)
1409  end if
1410 
1411  return
1412 
1413  end subroutine qrm_pdealloc_2i
1414 
1415 
1416 
1419  subroutine qrm_adealloc_d(a)
1420 
1421  real(kind(1.d0)), allocatable, dimension(:) :: a
1422 
1423  integer :: err=0, n
1424 
1425 
1426  if(allocated(a)) then
1427  n = size(a)
1428  deallocate(a, stat=err)
1429  else
1430  return
1431  end if
1432  if(err .ne. 0) then
1433  call qrm_err_push(7,sub='qrm_adealloc_d',ied=(/err,0,0,0,0/))
1434  else
1435  call qrm_mem_upd(-int(n,8)*qrm_sizeof_d_)
1436  end if
1437 
1438  return
1439 
1440  end subroutine qrm_adealloc_d
1441 
1444  subroutine qrm_adealloc_s(a)
1445 
1446  real(kind(1.e0)), allocatable, dimension(:) :: a
1447 
1448  integer :: err=0, n
1449 
1450  if(allocated(a)) then
1451  n = size(a)
1452  deallocate(a, stat=err)
1453  else
1454  return
1455  end if
1456  if(err .ne. 0) then
1457  call qrm_err_push(7,sub='qrm_adealloc_s',ied=(/err,0,0,0,0/))
1458  else
1459  call qrm_mem_upd(-int(n,8)*qrm_sizeof_s_)
1460  end if
1461 
1462  return
1463 
1464  end subroutine qrm_adealloc_s
1465 
1468  subroutine qrm_adealloc_i(a)
1469 
1470  integer, allocatable, dimension(:) :: a
1471 
1472  integer :: err=0, n
1473 
1474  if(allocated(a)) then
1475  n = size(a)
1476  deallocate(a, stat=err)
1477  else
1478  return
1479  end if
1480  if(err .ne. 0) then
1481  call qrm_err_push(7,sub='qrm_adealloc_i', ied=(/err,0,0,0,0/))
1482  else
1483  call qrm_mem_upd(-int(n,8)*qrm_sizeof_i_)
1484  end if
1485 
1486  return
1487 
1488  end subroutine qrm_adealloc_i
1489 
1492  subroutine qrm_adealloc_2d(a)
1493 
1494  real(kind(1.d0)), allocatable, dimension(:,:) :: a
1495 
1496  integer :: err=0, n, m
1497 
1498  if(allocated(a)) then
1499  m = size(a,1)
1500  n = size(a,2)
1501  deallocate(a, stat=err)
1502  else
1503  return
1504  end if
1505  if(err .ne. 0) then
1506  call qrm_err_push(7,sub='qrm_adealloc_2d',ied=(/err,0,0,0,0/))
1507  else
1508  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_d_)
1509  end if
1510 
1511  return
1512 
1513  end subroutine qrm_adealloc_2d
1514 
1517  subroutine qrm_adealloc_2s(a)
1518 
1519  real(kind(1.e0)), allocatable, dimension(:,:) :: a
1520 
1521  integer :: err=0, n, m
1522 
1523  if(allocated(a)) then
1524  m = size(a,1)
1525  n = size(a,2)
1526  deallocate(a, stat=err)
1527  else
1528  return
1529  end if
1530  if(err .ne. 0) then
1531  call qrm_err_push(7,sub='qrm_adealloc_2s',ied=(/err,0,0,0,0/))
1532  else
1533  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_s_)
1534  end if
1535 
1536  return
1537 
1538  end subroutine qrm_adealloc_2s
1539 
1540 
1543  subroutine qrm_adealloc_3d(a)
1544 
1545  real(kind(1.d0)), allocatable, dimension(:,:,:) :: a
1546 
1547  integer :: err=0, n, m, k
1548 
1549  if(allocated(a)) then
1550  m = size(a,1)
1551  n = size(a,2)
1552  k = size(a,3)
1553  deallocate(a, stat=err)
1554  else
1555  return
1556  end if
1557  if(err .ne. 0) then
1558  call qrm_err_push(7,sub='qrm_adealloc_3d',ied=(/err,0,0,0,0/))
1559  else
1560  call qrm_mem_upd(-int(m,8)*int(n,8)*int(k,8)*qrm_sizeof_d_)
1561  end if
1562 
1563  return
1564 
1565  end subroutine qrm_adealloc_3d
1566 
1569  subroutine qrm_adealloc_3s(a)
1570 
1571  real(kind(1.e0)), allocatable, dimension(:,:,:) :: a
1572 
1573  integer :: err=0, n, m, k
1574 
1575  if(allocated(a)) then
1576  m = size(a,1)
1577  n = size(a,2)
1578  k = size(a,3)
1579  deallocate(a, stat=err)
1580  else
1581  return
1582  end if
1583  if(err .ne. 0) then
1584  call qrm_err_push(7,sub='qrm_adealloc_3s',ied=(/err,0,0,0,0/))
1585  else
1586  call qrm_mem_upd(-int(m,8)*int(n,8)*int(k,8)*qrm_sizeof_s_)
1587  end if
1588 
1589  return
1590 
1591  end subroutine qrm_adealloc_3s
1592 
1593 
1594 
1597  subroutine qrm_adealloc_2i(a)
1598 
1599  integer, allocatable, dimension(:,:) :: a
1600 
1601  integer :: err=0, n, m
1602 
1603  if(allocated(a)) then
1604  m = size(a,1)
1605  n = size(a,2)
1606  deallocate(a, stat=err)
1607  else
1608  return
1609  end if
1610  if(err .ne. 0) then
1611  call qrm_err_push(7,sub='qrm_adealloc_2i',ied=(/err,0,0,0,0/))
1612  else
1613  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_i_)
1614  end if
1615 
1616  return
1617 
1618  end subroutine qrm_adealloc_2i
1619 
1620 
1627  subroutine qrm_prealloc_d(a, n, force, copy)
1628 
1629  real(kind(1.d0)), pointer, dimension(:) :: a
1630  integer :: n
1631  logical, optional :: force, copy
1632 
1633  integer :: err=0, asize, i
1634  logical :: iforce, icopy
1635  real(kind(1.d0)), pointer, dimension(:) :: tmp=>null()
1636 
1637  iforce=.false.
1638  if(present(force)) iforce=force
1639 
1640  ! if iforce=.true. we don't make any copies. Also, if a is not associated
1641  ! then there's nothing to copy.
1642  icopy = .false.
1643  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. associated(a))
1644 
1645  if(associated(a)) then
1646  ! a is associated
1647  asize = size(a)
1648  if(iforce .or. (size(a) .lt. n)) then
1649  ! we need to reallocate
1650  if(icopy) then
1651  ! we must save a copy
1652  tmp => a
1653  nullify(a)
1654  else
1655  deallocate(a, stat=err)
1656  if(err .ne. 0) then
1657  call qrm_err_push(7, sub='qrm_prealloc_d',ied=(/err,0,0,0,0/))
1658  else
1659  call qrm_mem_upd(-asize*qrm_sizeof_d_)
1660  end if
1661  end if
1662  ! reallocate a
1663  allocate(a(n), stat=err)
1664  if(err .ne. 0) then
1665  call qrm_err_push(5,sub='qrm_palloc_d',ied=(/n,0,0,0,0/))
1666  else
1667  call qrm_mem_upd(int(n,8)*qrm_sizeof_d_)
1668  end if
1669  else
1670  return
1671  end if
1672  else
1673  ! allocate a
1674  allocate(a(n), stat=err)
1675  if(err .ne. 0) then
1676  call qrm_err_push(5,sub='qrm_palloc_d',ied=(/n,0,0,0,0/))
1677  else
1678  call qrm_mem_upd(int(n,8)*qrm_sizeof_d_)
1679  end if
1680  end if
1681 
1682  ! check if copy is to be done
1683  if(icopy) then
1684  do i=1, asize
1685  a(i) = tmp(i)
1686  end do
1687  deallocate(tmp, stat=err)
1688  if(err .ne. 0) then
1689  call qrm_err_push(7, sub='qrm_prealloc_d',ied=(/err,0,0,0,0/))
1690  else
1691  call qrm_mem_upd(-asize*qrm_sizeof_d_)
1692  end if
1693  end if
1694 
1695  return
1696 
1697  end subroutine qrm_prealloc_d
1698 
1699 
1706  subroutine qrm_prealloc_s(a, n, force, copy)
1707 
1708  real(kind(1.e0)), pointer, dimension(:) :: a
1709  integer :: n
1710  logical, optional :: force, copy
1711 
1712  integer :: err=0, asize, i
1713  logical :: iforce, icopy
1714  real(kind(1.e0)), pointer, dimension(:) :: tmp=>null()
1715 
1716  iforce=.false.
1717  if(present(force)) iforce=force
1718 
1719  ! if iforce=.true. we don't make any copies. Also, if a is not associated
1720  ! then there's nothing to copy.
1721  icopy = .false.
1722  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. associated(a))
1723 
1724  if(associated(a)) then
1725  ! a is associated
1726  asize = size(a)
1727  if(iforce .or. (size(a) .lt. n)) then
1728  ! we need to reallocate
1729  if(icopy) then
1730  ! we must save a copy
1731  tmp => a
1732  nullify(a)
1733  else
1734  deallocate(a, stat=err)
1735  if(err .ne. 0) then
1736  call qrm_err_push(7, sub='qrm_prealloc_s',ied=(/err,0,0,0,0/))
1737  else
1738  call qrm_mem_upd(-asize*qrm_sizeof_s_)
1739  end if
1740  end if
1741  ! reallocate a
1742  allocate(a(n), stat=err)
1743  if(err .ne. 0) then
1744  call qrm_err_push(5,sub='qrm_prealloc_s',ied=(/n,0,0,0,0/))
1745  else
1746  call qrm_mem_upd(+int(n,8)*qrm_sizeof_s_)
1747  end if
1748  else
1749  return
1750  end if
1751  else
1752  ! allocate a
1753  allocate(a(n), stat=err)
1754  if(err .ne. 0) then
1755  call qrm_err_push(5,sub='qrm_prealloc_s',ied=(/n,0,0,0,0/))
1756  else
1757  call qrm_mem_upd(+int(n,8)*qrm_sizeof_s_)
1758  end if
1759  end if
1760 
1761  ! check if copy is to be done
1762  if(icopy) then
1763  do i=1, asize
1764  a(i) = tmp(i)
1765  end do
1766  deallocate(tmp, stat=err)
1767  if(err .ne. 0) then
1768  call qrm_err_push(7, sub='qrm_prealloc_s',ied=(/err,0,0,0,0/))
1769  else
1770  call qrm_mem_upd(-asize*qrm_sizeof_s_)
1771  end if
1772  end if
1773 
1774  return
1775 
1776  end subroutine qrm_prealloc_s
1777 
1778 
1785  subroutine qrm_prealloc_i(a, n, force, copy)
1786 
1787  integer, pointer, dimension(:) :: a
1788  integer :: n
1789  logical, optional :: force, copy
1790 
1791  integer :: err=0, asize, i
1792  logical :: iforce, icopy
1793  integer, pointer, dimension(:) :: tmp=>null()
1794 
1795  iforce=.false.
1796  if(present(force)) iforce=force
1797 
1798  ! if iforce=.true. we don't make any copies. Also, if a is not associated
1799  ! then there's nothing to copy.
1800  icopy = .false.
1801  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. associated(a))
1802 
1803  if(associated(a)) then
1804  ! a is associated
1805  asize = size(a)
1806  if(iforce .or. (size(a) .lt. n)) then
1807  ! we need to reallocate
1808  if(icopy) then
1809  ! we must save a copy
1810  tmp => a
1811  nullify(a)
1812  else
1813  deallocate(a, stat=err)
1814  if(err .ne. 0) then
1815  call qrm_err_push(7, sub='qrm_prealloc_i',ied=(/err,0,0,0,0/))
1816  else
1817  call qrm_mem_upd(-asize*qrm_sizeof_i_)
1818  end if
1819  end if
1820  ! reallocate a
1821  allocate(a(n), stat=err)
1822  if(err .ne. 0) then
1823  call qrm_err_push(5,sub='qrm_prealloc_i',ied=(/n,0,0,0,0/))
1824  else
1825  call qrm_mem_upd(+int(n,8)*qrm_sizeof_i_)
1826  end if
1827  else
1828  return
1829  end if
1830  else
1831  ! allocate a
1832  allocate(a(n), stat=err)
1833  if(err .ne. 0) then
1834  call qrm_err_push(5,sub='qrm_prealloc_i',ied=(/n,0,0,0,0/))
1835  else
1836  call qrm_mem_upd(+int(n,8)*qrm_sizeof_i_)
1837  end if
1838  end if
1839 
1840  ! check if copy is to be done
1841  if(icopy) then
1842  do i=1, asize
1843  a(i) = tmp(i)
1844  end do
1845  deallocate(tmp, stat=err)
1846  if(err .ne. 0) then
1847  call qrm_err_push(7, sub='qrm_prealloc_i',ied=(/err,0,0,0,0/))
1848  else
1849  call qrm_mem_upd(-asize*qrm_sizeof_i_)
1850  end if
1851  end if
1852 
1853  return
1854 
1855  end subroutine qrm_prealloc_i
1856 
1857 
1864  subroutine qrm_arealloc_d(a, n, force, copy)
1865 
1866  real(kind(1.d0)), allocatable, dimension(:) :: a
1867  integer :: n
1868  logical, optional :: force, copy
1869 
1870  integer :: err=0, asize, i
1871  logical :: iforce, icopy
1872  real(kind(1.d0)), allocatable, dimension(:) :: tmp
1873 
1874  iforce=.false.
1875  if(present(force)) iforce=force
1876 
1877  ! if iforce=.true. we don't make any copies. Also, if a is not allocated
1878  ! then there's nothing to copy.
1879  icopy = .false.
1880  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. allocated(a))
1881 
1882  if(allocated(a)) then
1883  ! a is allocated
1884  asize = size(a)
1885  if(iforce .or. (size(a) .lt. n)) then
1886  ! we need to reallocate
1887  if(.not. icopy) then
1888  deallocate(a, stat=err)
1889  if(err .ne. 0) then
1890  call qrm_err_push(7, sub='qrm_arealloc_d',ied=(/err,0,0,0,0/))
1891  else
1892  call qrm_mem_upd(-asize*qrm_sizeof_d_)
1893  end if
1894  end if
1895  ! allocate tmp
1896  allocate(tmp(n), stat=err)
1897  if(err .ne. 0) then
1898  call qrm_err_push(5,sub='qrm_arealloc_d',ied=(/n,0,0,0,0/))
1899  else
1900  call qrm_mem_upd(+int(n,8)*qrm_sizeof_d_)
1901  end if
1902  else
1903  return
1904  end if
1905  else
1906  ! allocate a
1907  allocate(tmp(n), stat=err)
1908  if(err .ne. 0) then
1909  call qrm_err_push(5,sub='qrm_arealloc_d',ied=(/n,0,0,0,0/))
1910  else
1911  call qrm_mem_upd(+int(n,8)*qrm_sizeof_d_)
1912  end if
1913  end if
1914 
1915  ! check if copy is to be done
1916  if(icopy) then
1917  do i=1, asize
1918  tmp(i) = a(i)
1919  end do
1920  deallocate(a, stat=err)
1921  if(err .ne. 0) then
1922  call qrm_err_push(7, sub='qrm_arealloc_d',ied=(/err,0,0,0,0/))
1923  else
1924  call qrm_mem_upd(-asize*qrm_sizeof_d_)
1925  end if
1926  end if
1927 
1928  call move_alloc(from=tmp, to=a)
1929 
1930  return
1931 
1932  end subroutine qrm_arealloc_d
1933 
1934 
1941  subroutine qrm_arealloc_s(a, n, force, copy)
1942 
1943  real(kind(1.e0)), allocatable, dimension(:) :: a
1944  integer :: n
1945  logical, optional :: force, copy
1946 
1947  integer :: err=0, asize, i
1948  logical :: iforce, icopy
1949  real(kind(1.e0)), allocatable, dimension(:) :: tmp
1950 
1951  iforce=.false.
1952  if(present(force)) iforce=force
1953 
1954  ! if iforce=.true. we don't make any copies. Also, if a is not allocated
1955  ! then there's nothing to copy.
1956  icopy = .false.
1957  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. allocated(a))
1958 
1959  if(allocated(a)) then
1960  ! a is allocated
1961  asize = size(a)
1962  if(iforce .or. (size(a) .lt. n)) then
1963  ! we need to reallocate
1964  if(.not. icopy) then
1965  deallocate(a, stat=err)
1966  if(err .ne. 0) then
1967  call qrm_err_push(7, sub='qrm_arealloc_s',ied=(/err,0,0,0,0/))
1968  else
1969  call qrm_mem_upd(-asize*qrm_sizeof_s_)
1970  end if
1971  end if
1972  ! allocate tmp
1973  allocate(tmp(n), stat=err)
1974  if(err .ne. 0) then
1975  call qrm_err_push(5,sub='qrm_arealloc_s',ied=(/n,0,0,0,0/))
1976  else
1977  call qrm_mem_upd(+int(n,8)*qrm_sizeof_s_)
1978  end if
1979  else
1980  return
1981  end if
1982  else
1983  ! allocate a
1984  allocate(tmp(n), stat=err)
1985  if(err .ne. 0) then
1986  call qrm_err_push(5,sub='qrm_arealloc_s',ied=(/n,0,0,0,0/))
1987  else
1988  call qrm_mem_upd(+int(n,8)*qrm_sizeof_s_)
1989  end if
1990  end if
1991 
1992  ! check if copy is to be done
1993  if(icopy) then
1994  do i=1, asize
1995  tmp(i) = a(i)
1996  end do
1997  deallocate(a, stat=err)
1998  if(err .ne. 0) then
1999  call qrm_err_push(7, sub='qrm_arealloc_s',ied=(/err,0,0,0,0/))
2000  else
2001  call qrm_mem_upd(-asize*qrm_sizeof_s_)
2002  end if
2003  end if
2004 
2005  call move_alloc(from=tmp, to=a)
2006 
2007  return
2008 
2009  end subroutine qrm_arealloc_s
2010 
2011 
2018  subroutine qrm_arealloc_i(a, n, force, copy)
2019 
2020  integer, allocatable, dimension(:) :: a
2021  integer :: n
2022  logical, optional :: force, copy
2023 
2024  integer :: err=0, asize, i
2025  logical :: iforce, icopy
2026  integer, allocatable, dimension(:) :: tmp
2027 
2028  iforce=.false.
2029  if(present(force)) iforce=force
2030 
2031  ! if iforce=.true. we don't make any copies. Also, if a is not allocated
2032  ! then there's nothing to copy.
2033  icopy = .false.
2034  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. allocated(a))
2035 
2036  if(allocated(a)) then
2037  ! a is allocated
2038  asize = size(a)
2039  if(iforce .or. (size(a) .lt. n)) then
2040  ! we need to reallocate
2041  if(.not. icopy) then
2042  deallocate(a, stat=err)
2043  if(err .ne. 0) then
2044  call qrm_err_push(7, sub='qrm_arealloc_i',ied=(/err,0,0,0,0/))
2045  else
2046  call qrm_mem_upd(-asize*qrm_sizeof_i_)
2047  end if
2048  end if
2049  ! allocate tmp
2050  allocate(tmp(n), stat=err)
2051  if(err .ne. 0) then
2052  call qrm_err_push(5,sub='qrm_arealloc_i',ied=(/n,0,0,0,0/))
2053  else
2054  call qrm_mem_upd(+int(n,8)*qrm_sizeof_i_)
2055  end if
2056  else
2057  return
2058  end if
2059  else
2060  ! allocate a
2061  allocate(tmp(n), stat=err)
2062  if(err .ne. 0) then
2063  call qrm_err_push(5,sub='qrm_arealloc_i',ied=(/n,0,0,0,0/))
2064  else
2065  call qrm_mem_upd(+int(n,8)*qrm_sizeof_i_)
2066  end if
2067  end if
2068 
2069  ! check if copy is to be done
2070  if(icopy) then
2071  do i=1, asize
2072  tmp(i) = a(i)
2073  end do
2074  deallocate(a, stat=err)
2075  if(err .ne. 0) then
2076  call qrm_err_push(7, sub='qrm_arealloc_i',ied=(/err,0,0,0,0/))
2077  else
2078  call qrm_mem_upd(-asize*qrm_sizeof_i_)
2079  end if
2080  end if
2081 
2082  call move_alloc(from=tmp, to=a)
2083 
2084  return
2085 
2086  end subroutine qrm_arealloc_i
2087 
2088 
2089 
2090 
2093  function qrm_asize_i(a)
2094 
2095  implicit none
2096 
2097  integer :: qrm_asize_i
2098  integer, allocatable :: a(:)
2099 
2100  if(allocated(a)) then
2101  ! a is allocated
2102  qrm_asize_i = size(a)
2103  else
2104  qrm_asize_i = 0
2105  end if
2106 
2107  return
2108 
2109  end function qrm_asize_i
2110 
2111 
2114  function qrm_asize_s(a)
2115 
2116  implicit none
2117 
2118  integer :: qrm_asize_s
2119  real(kind(1.e0)), allocatable :: a(:)
2120 
2121  if(allocated(a)) then
2122  ! a is allocated
2123  qrm_asize_s = size(a)
2124  else
2125  qrm_asize_s = 0
2126  end if
2127 
2128  return
2129 
2130  end function qrm_asize_s
2131 
2134  function qrm_asize_d(a)
2135 
2136  implicit none
2137 
2138  integer :: qrm_asize_d
2139  real(kind(1.d0)), allocatable :: a(:)
2140 
2141  if(allocated(a)) then
2142  ! a is allocated
2143  qrm_asize_d = size(a)
2144  else
2145  qrm_asize_d = 0
2146  end if
2147 
2148  return
2149 
2150  end function qrm_asize_d
2151 
2152 
2155  function qrm_asize_2s(a)
2156 
2157  implicit none
2158 
2159  integer :: qrm_asize_2s
2160  real(kind(1.e0)), allocatable :: a(:,:)
2161 
2162  if(allocated(a)) then
2163  ! a is allocated
2164  qrm_asize_2s = size(a)
2165  else
2166  qrm_asize_2s = 0
2167  end if
2168 
2169  return
2170 
2171  end function qrm_asize_2s
2172 
2175  function qrm_asize_2d(a)
2176 
2177  implicit none
2178 
2179  integer :: qrm_asize_2d
2180  real(kind(1.d0)), allocatable :: a(:,:)
2181 
2182  if(allocated(a)) then
2183  ! a is allocated
2184  qrm_asize_2d = size(a)
2185  else
2186  qrm_asize_2d = 0
2187  end if
2188 
2189  return
2190 
2191  end function qrm_asize_2d
2192 
2193 
2194 
2197  function qrm_asize_3s(a)
2198 
2199  implicit none
2200 
2201  integer :: qrm_asize_3s
2202  real(kind(1.e0)), allocatable :: a(:,:,:)
2203 
2204  if(allocated(a)) then
2205  ! a is allocated
2206  qrm_asize_3s = size(a)
2207  else
2208  qrm_asize_3s = 0
2209  end if
2210 
2211  return
2212 
2213  end function qrm_asize_3s
2214 
2215 
2218  function qrm_asize_3d(a)
2219 
2220  implicit none
2221 
2222  integer :: qrm_asize_3d
2223  real(kind(1.d0)), allocatable :: a(:,:,:)
2224 
2225  if(allocated(a)) then
2226  ! a is allocated
2227  qrm_asize_3d = size(a)
2228  else
2229  qrm_asize_3d = 0
2230  end if
2231 
2232  return
2233 
2234  end function qrm_asize_3d
2235 
2236 
2244  subroutine qrm_palloc_z(a, n, info)
2245 
2246  complex(kind(1.d0)), pointer, dimension(:) :: a
2247  integer, intent(in) :: n
2248  integer, optional :: info
2249 
2250  integer :: err, disp
2251 
2252  if(associated(a)) then
2253  call qrm_err_push(4,sub='qrm_palloc_z')
2254  else
2255 #if defined(memlim)
2256  !$omp critical(mem)
2257  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2258  !$omp end critical(mem)
2259  if( n*qrm_sizeof_z_ .gt. disp ) then
2260  err = 1
2261  else
2262  allocate(a(n), stat=err)
2263  end if
2264 #else
2265  allocate(a(n), stat=err)
2266 #endif
2267  if(err .ne. 0) then
2268  if(present(info)) then
2269  info = err
2270  else
2271  call qrm_err_push(5,sub='qrm_palloc_z',ied=(/n,0,0,0,0/))
2272  end if
2273  else
2274  call qrm_mem_upd(+int(n,8)*qrm_sizeof_z_)
2275  end if
2276  end if
2277 
2278  return
2279 
2280  end subroutine qrm_palloc_z
2281 
2289  subroutine qrm_palloc_z_8(a, n, info)
2290 
2291  complex(kind(1.d0)), pointer, dimension(:) :: a
2292  integer(kind=8), intent(in) :: n
2293  integer, optional :: info
2294 
2295  integer :: err, disp
2296 
2297  if(associated(a)) then
2298  call qrm_err_push(4,sub='qrm_palloc_z')
2299  else
2300 #if defined(memlim)
2301  !$omp critical(mem)
2302  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2303  !$omp end critical(mem)
2304  if( n*qrm_sizeof_z_ .gt. disp ) then
2305  err = 1
2306  else
2307  allocate(a(n), stat=err)
2308  end if
2309 #else
2310  allocate(a(n), stat=err)
2311 #endif
2312  if(err .ne. 0) then
2313  if(present(info)) then
2314  info = err
2315  else
2316  call qrm_err_push(5,sub='qrm_palloc_z',ied=(/int(n,4),0,0,0,0/))
2317  end if
2318  else
2319  call qrm_mem_upd(+int(n,8)*qrm_sizeof_z_)
2320  end if
2321  end if
2322 
2323  return
2324 
2325  end subroutine qrm_palloc_z_8
2326 
2327 
2335  subroutine qrm_palloc_c(a, n, info)
2336 
2337  complex(kind(1.e0)), pointer, dimension(:) :: a
2338  integer, intent(in) :: n
2339  integer, optional :: info
2340 
2341  integer :: err, disp
2342 
2343  if(n .lt. 0) return
2344 
2345  if(associated(a)) then
2346  call qrm_err_push(4,sub='qrm_palloc_c')
2347  else
2348 #if defined(memlim)
2349  !$omp critical(mem)
2350  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2351  !$omp end critical(mem)
2352  if( n*qrm_sizeof_c_ .gt. disp ) then
2353  err = 1
2354  else
2355  allocate(a(n), stat=err)
2356  end if
2357 #else
2358  allocate(a(n), stat=err)
2359 #endif
2360  if(err .ne. 0) then
2361  if(present(info)) then
2362  info = err
2363  else
2364  call qrm_err_push(5,sub='qrm_palloc_c',ied=(/n,0,0,0,0/))
2365  end if
2366  else
2367  call qrm_mem_upd(+int(n,8)*qrm_sizeof_c_)
2368  end if
2369 
2370  end if
2371 
2372  return
2373 
2374  end subroutine qrm_palloc_c
2375 
2383  subroutine qrm_palloc_c_8(a, n, info)
2384 
2385  complex(kind(1.e0)), pointer, dimension(:) :: a
2386  integer(kind=8), intent(in) :: n
2387  integer, optional :: info
2388 
2389  integer :: err, disp
2390 
2391  if(n .lt. 0) return
2392 
2393  if(associated(a)) then
2394  call qrm_err_push(4,sub='qrm_palloc_c')
2395  else
2396 #if defined(memlim)
2397  !$omp critical(mem)
2398  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2399  !$omp end critical(mem)
2400  if( n*qrm_sizeof_c_ .gt. disp ) then
2401  err = 1
2402  else
2403  allocate(a(n), stat=err)
2404  end if
2405 #else
2406  allocate(a(n), stat=err)
2407 #endif
2408  if(err .ne. 0) then
2409  if(present(info)) then
2410  info = err
2411  else
2412  call qrm_err_push(5,sub='qrm_palloc_c',ied=(/int(n,4),0,0,0,0/))
2413  end if
2414  else
2415  call qrm_mem_upd(+int(n,8)*qrm_sizeof_c_)
2416  end if
2417 
2418  end if
2419 
2420  return
2421 
2422  end subroutine qrm_palloc_c_8
2423 
2424 
2434  subroutine qrm_aalloc_z(a, n, lbnd, info)
2435 
2436  complex(kind(1.d0)), allocatable, dimension(:) :: a
2437  integer, intent(in) :: n
2438  integer, optional :: lbnd
2439  integer, optional :: info
2440 
2441  integer :: err, ilbnd, disp
2442 
2443  if(n .lt. 0) return
2444 
2445  if(allocated(a)) then
2446  call qrm_err_push(4,sub='qrm_aalloc_z')
2447  else
2448  if(present(lbnd)) then
2449  ilbnd = lbnd
2450  else
2451  ilbnd = 1
2452  end if
2453 
2454 #if defined(memlim)
2455  !$omp critical(mem)
2456  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2457  !$omp end critical(mem)
2458  if( n*qrm_sizeof_z_ .gt. disp ) then
2459  err = 1
2460  else
2461  allocate(a(ilbnd: ilbnd+n-1), stat=err)
2462  end if
2463 #else
2464  allocate(a(ilbnd: ilbnd+n-1), stat=err)
2465 #endif
2466  if(err .ne. 0) then
2467  if(present(info)) then
2468  info = err
2469  else
2470  call qrm_err_push(5,sub='qrm_aalloc_z',ied=(/n,0,0,0,0/))
2471  end if
2472  else
2473  call qrm_mem_upd(+int(n,8)*qrm_sizeof_z_)
2474  end if
2475 
2476  end if
2477 
2478  return
2479 
2480  end subroutine qrm_aalloc_z
2481 
2491  subroutine qrm_aalloc_c(a, n, lbnd, info)
2492 
2493  complex(kind(1.e0)), allocatable, dimension(:) :: a
2494  integer, intent(in) :: n
2495  integer, optional :: lbnd
2496  integer, optional :: info
2497 
2498  integer :: err, ilbnd, disp
2499 
2500  if(n .lt. 0) return
2501 
2502  if(allocated(a)) then
2503  call qrm_err_push(4,sub='qrm_aalloc_c')
2504  else
2505  if(present(lbnd)) then
2506  ilbnd = lbnd
2507  else
2508  ilbnd = 1
2509  end if
2510 
2511 #if defined(memlim)
2512  !$omp critical(mem)
2513  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2514  !$omp end critical(mem)
2515  if( n*qrm_sizeof_c_ .gt. disp ) then
2516  err = 1
2517  else
2518  allocate(a(ilbnd: ilbnd+n-1), stat=err)
2519  end if
2520 #else
2521  allocate(a(ilbnd: ilbnd+n-1), stat=err)
2522 #endif
2523  if(err .ne. 0) then
2524  if(present(info)) then
2525  info = err
2526  else
2527  call qrm_err_push(5,sub='qrm_aalloc_c',ied=(/n,0,0,0,0/))
2528  end if
2529  else
2530  call qrm_mem_upd(+int(n,8)*qrm_sizeof_c_)
2531  end if
2532 
2533  end if
2534 
2535  return
2536 
2537  end subroutine qrm_aalloc_c
2538 
2539 
2549  subroutine qrm_aalloc_2z(a, m, n, info)
2550 
2551  complex(kind(1.d0)), allocatable, dimension(:,:) :: a
2552  integer, intent(in) :: m, n
2553  integer, optional :: info
2554 
2555  integer :: err, disp
2556 
2557  if(min(m,n) .lt. 0) return
2558 
2559  if(allocated(a)) then
2560  call qrm_err_push(4,sub='qrm_aalloc_2z')
2561  else
2562 #if defined(memlim)
2563  !$omp critical(mem)
2564  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2565  !$omp end critical(mem)
2566  if( n*m*qrm_sizeof_z_ .gt. disp ) then
2567  err = 1
2568  else
2569  allocate(a(m,n), stat=err)
2570  end if
2571 #else
2572  allocate(a(m,n), stat=err)
2573 #endif
2574  if(err .ne. 0) then
2575  if(present(info)) then
2576  info = err
2577  else
2578  call qrm_err_push(5,sub='qrm_aalloc_2z',ied=(/n,0,0,0,0/))
2579  end if
2580  else
2581  call qrm_mem_upd(+int(m,8)*int(n,8)*qrm_sizeof_z_)
2582  end if
2583 
2584  end if
2585 
2586  return
2587 
2588  end subroutine qrm_aalloc_2z
2589 
2599  subroutine qrm_aalloc_2c(a, m, n, info)
2600 
2601  complex(kind(1.e0)), allocatable, dimension(:,:) :: a
2602  integer, intent(in) :: m, n
2603  integer, optional :: info
2604 
2605  integer :: err, disp
2606 
2607  if(min(m,n) .lt. 0) return
2608 
2609  if(allocated(a)) then
2610  call qrm_err_push(4,sub='qrm_aalloc_2c')
2611  else
2612 #if defined(memlim)
2613  !$omp critical(mem)
2614  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2615  !$omp end critical(mem)
2616  if( n*m*qrm_sizeof_c_ .gt. disp ) then
2617  err = 1
2618  else
2619  allocate(a(m,n), stat=err)
2620  end if
2621 #else
2622  allocate(a(m,n), stat=err)
2623 #endif
2624  if(err .ne. 0) then
2625  if(present(info)) then
2626  info = err
2627  else
2628  call qrm_err_push(5,sub='qrm_aalloc_2c',ied=(/n,0,0,0,0/))
2629  end if
2630  else
2631  call qrm_mem_upd(+int(m,8)*int(n,8)*qrm_sizeof_c_)
2632  end if
2633 
2634  end if
2635 
2636  return
2637 
2638  end subroutine qrm_aalloc_2c
2639 
2640 
2641 
2642 
2654  subroutine qrm_aalloc_3z(a, m, n, k, info)
2655 
2656  complex(kind(1.d0)), allocatable, dimension(:,:,:) :: a
2657  integer, intent(in) :: m, n, k
2658  integer, optional :: info
2659 
2660  integer :: err, disp
2661 
2662  if(min(min(m,n),k) .lt. 0) return
2663 
2664  if(allocated(a)) then
2665  call qrm_err_push(4,sub='qrm_aalloc_3z')
2666  else
2667 #if defined(memlim)
2668  !$omp critical(mem)
2669  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2670  !$omp end critical(mem)
2671  if( n*m*k*qrm_sizeof_z_ .gt. disp ) then
2672  err = 1
2673  else
2674  allocate(a(m,n,k), stat=err)
2675  end if
2676 #else
2677  allocate(a(m,n,k), stat=err)
2678 #endif
2679  if(err .ne. 0) then
2680  if(present(info)) then
2681  info = err
2682  else
2683  call qrm_err_push(5,sub='qrm_aalloc_3z',ied=(/n,0,0,0,0/))
2684  end if
2685  else
2686  call qrm_mem_upd(+int(m,8)*int(n,8)*int(k,8)*qrm_sizeof_z_)
2687  end if
2688 
2689  end if
2690 
2691  return
2692 
2693  end subroutine qrm_aalloc_3z
2694 
2695 
2707  subroutine qrm_aalloc_3c(a, m, n, k, info)
2708 
2709  complex(kind(1.e0)), allocatable, dimension(:,:,:) :: a
2710  integer, intent(in) :: m, n, k
2711  integer, optional :: info
2712 
2713  integer :: err, disp
2714 
2715  if(min(min(m,n),k) .lt. 0) return
2716 
2717  if(allocated(a)) then
2718  call qrm_err_push(4,sub='qrm_aalloc_3c')
2719  else
2720 #if defined(memlim)
2721  !$omp critical(mem)
2722  disp = qrm_mem_lim - sum(qrm_tot_mem(0:qrm_mem_nth-1))
2723  !$omp end critical(mem)
2724  if( n*m*k*qrm_sizeof_c_ .gt. disp ) then
2725  err = 1
2726  else
2727  allocate(a(m,n,k), stat=err)
2728  end if
2729 #else
2730  allocate(a(m,n,k), stat=err)
2731 #endif
2732  if(err .ne. 0) then
2733  if(present(info)) then
2734  info = err
2735  else
2736  call qrm_err_push(5,sub='qrm_aalloc_3c',ied=(/n,0,0,0,0/))
2737  end if
2738  else
2739  call qrm_mem_upd(+int(m,8)*int(n,8)*int(k,8)*qrm_sizeof_c_)
2740  end if
2741 
2742  end if
2743 
2744  return
2745 
2746  end subroutine qrm_aalloc_3c
2747 
2748 
2749 
2750 !!!!!!!!!!!!!!!!
2751 !! Deallocation
2752 !!!!!!!!!!!!!!!!
2753 
2754 
2757  subroutine qrm_pdealloc_z(a)
2758 
2759  complex(kind(1.d0)), pointer, dimension(:) :: a
2760 
2761  integer :: err=0, n
2762 
2763  if(associated(a)) then
2764  n = size(a)
2765  deallocate(a, stat=err)
2766  else
2767  return
2768  end if
2769  if(err .ne. 0) then
2770  call qrm_err_push(7,sub='qrm_pdealloc_z',ied=(/err,0,0,0,0/))
2771  else
2772  call qrm_mem_upd(-int(n,8)*qrm_sizeof_z_)
2773  end if
2774 
2775  return
2776 
2777  end subroutine qrm_pdealloc_z
2778 
2781  subroutine qrm_pdealloc_c(a)
2782 
2783  complex(kind(1.e0)), pointer, dimension(:) :: a
2784 
2785  integer :: err=0, n
2786 
2787  if(associated(a)) then
2788  n = size(a)
2789  deallocate(a, stat=err)
2790  else
2791  return
2792  end if
2793  if(err .ne. 0) then
2794  call qrm_err_push(7,sub='qrm_pdealloc_c',ied=(/err,0,0,0,0/))
2795  else
2796  call qrm_mem_upd(-int(n,8)*qrm_sizeof_c_)
2797  end if
2798 
2799  return
2800 
2801  end subroutine qrm_pdealloc_c
2802 
2803 
2806  subroutine qrm_pdealloc_2z(a)
2807 
2808  complex(kind(1.d0)), pointer, dimension(:,:) :: a
2809 
2810  integer :: err=0, n, m
2811 
2812  if(associated(a)) then
2813  m = size(a,1)
2814  n = size(a,2)
2815  deallocate(a, stat=err)
2816  else
2817  return
2818  end if
2819  if(err .ne. 0) then
2820  call qrm_err_push(7,sub='qrm_pdealloc_2z',ied=(/err,0,0,0,0/))
2821  else
2822  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_z_)
2823  end if
2824 
2825  return
2826 
2827  end subroutine qrm_pdealloc_2z
2828 
2831  subroutine qrm_pdealloc_2c(a)
2832 
2833  complex(kind(1.e0)), pointer, dimension(:,:) :: a
2834 
2835  integer :: err=0, n, m
2836 
2837  if(associated(a)) then
2838  m = size(a,1)
2839  n = size(a,2)
2840  deallocate(a, stat=err)
2841  else
2842  return
2843  end if
2844  if(err .ne. 0) then
2845  call qrm_err_push(7,sub='qrm_pdealloc_2c',ied=(/err,0,0,0,0/))
2846  else
2847  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_c_)
2848  end if
2849 
2850  return
2851 
2852  end subroutine qrm_pdealloc_2c
2853 
2854 
2857  subroutine qrm_adealloc_z(a)
2858 
2859  complex(kind(1.d0)), allocatable, dimension(:) :: a
2860 
2861  integer :: err=0, n
2862 
2863 
2864  if(allocated(a)) then
2865  n = size(a)
2866  deallocate(a, stat=err)
2867  else
2868  return
2869  end if
2870  if(err .ne. 0) then
2871  call qrm_err_push(7,sub='qrm_adealloc_z',ied=(/err,0,0,0,0/))
2872  else
2873  call qrm_mem_upd(-int(n,8)*qrm_sizeof_z_)
2874  end if
2875 
2876  return
2877 
2878  end subroutine qrm_adealloc_z
2879 
2882  subroutine qrm_adealloc_c(a)
2883 
2884  complex(kind(1.e0)), allocatable, dimension(:) :: a
2885 
2886  integer :: err=0, n
2887 
2888  if(allocated(a)) then
2889  n = size(a)
2890  deallocate(a, stat=err)
2891  else
2892  return
2893  end if
2894  if(err .ne. 0) then
2895  call qrm_err_push(7,sub='qrm_adealloc_c',ied=(/err,0,0,0,0/))
2896  else
2897  call qrm_mem_upd(-int(n,8)*qrm_sizeof_c_)
2898  end if
2899 
2900  return
2901 
2902  end subroutine qrm_adealloc_c
2903 
2906  subroutine qrm_adealloc_2z(a)
2907 
2908  complex(kind(1.d0)), allocatable, dimension(:,:) :: a
2909 
2910  integer :: err=0, n, m
2911 
2912  if(allocated(a)) then
2913  m = size(a,1)
2914  n = size(a,2)
2915  deallocate(a, stat=err)
2916  else
2917  return
2918  end if
2919  if(err .ne. 0) then
2920  call qrm_err_push(7,sub='qrm_adealloc_2z',ied=(/err,0,0,0,0/))
2921  else
2922  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_z_)
2923  end if
2924 
2925  return
2926 
2927  end subroutine qrm_adealloc_2z
2928 
2931  subroutine qrm_adealloc_2c(a)
2932 
2933  complex(kind(1.e0)), allocatable, dimension(:,:) :: a
2934 
2935  integer :: err=0, n, m
2936 
2937  if(allocated(a)) then
2938  m = size(a,1)
2939  n = size(a,2)
2940  deallocate(a, stat=err)
2941  else
2942  return
2943  end if
2944  if(err .ne. 0) then
2945  call qrm_err_push(7,sub='qrm_adealloc_2c',ied=(/err,0,0,0,0/))
2946  else
2947  call qrm_mem_upd(-int(m,8)*int(n,8)*qrm_sizeof_c_)
2948  end if
2949 
2950  return
2951 
2952  end subroutine qrm_adealloc_2c
2953 
2954 
2957  subroutine qrm_adealloc_3z(a)
2958 
2959  complex(kind(1.d0)), allocatable, dimension(:,:,:) :: a
2960 
2961  integer :: err=0, n, m, k
2962 
2963  if(allocated(a)) then
2964  m = size(a,1)
2965  n = size(a,2)
2966  k = size(a,3)
2967  deallocate(a, stat=err)
2968  else
2969  return
2970  end if
2971  if(err .ne. 0) then
2972  call qrm_err_push(7,sub='qrm_adealloc_3z',ied=(/err,0,0,0,0/))
2973  else
2974  call qrm_mem_upd(-int(m,8)*int(n,8)*int(k,8)*qrm_sizeof_z_)
2975  end if
2976 
2977  return
2978 
2979  end subroutine qrm_adealloc_3z
2980 
2983  subroutine qrm_adealloc_3c(a)
2984 
2985  complex(kind(1.e0)), allocatable, dimension(:,:,:) :: a
2986 
2987  integer :: err=0, n, m, k
2988 
2989  if(allocated(a)) then
2990  m = size(a,1)
2991  n = size(a,2)
2992  k = size(a,3)
2993  deallocate(a, stat=err)
2994  else
2995  return
2996  end if
2997  if(err .ne. 0) then
2998  call qrm_err_push(7,sub='qrm_adealloc_3c',ied=(/err,0,0,0,0/))
2999  else
3000  call qrm_mem_upd(-int(m,8)*int(n,8)*int(k,8)*qrm_sizeof_c_)
3001  end if
3002 
3003  return
3004 
3005  end subroutine qrm_adealloc_3c
3006 
3007 
3008 
3009 !!!!!!!!!!!!!!!
3010 !! Reallocation
3011 !!!!!!!!!!!!!!!
3012 
3013 
3020  subroutine qrm_prealloc_z(a, n, force, copy)
3021 
3022  complex(kind(1.d0)), pointer, dimension(:) :: a
3023  integer :: n
3024  logical, optional :: force, copy
3025 
3026  integer :: err=0, asize, i
3027  logical :: iforce, icopy
3028  complex(kind(1.d0)), pointer, dimension(:) :: tmp=>null()
3029 
3030  iforce=.false.
3031  if(present(force)) iforce=force
3032 
3033  ! if iforce=.true. we don't make any copies. Also, if a is not associated
3034  ! then there's nothing to copy.
3035  icopy = .false.
3036  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. associated(a))
3037 
3038  if(associated(a)) then
3039  ! a is associated
3040  asize = size(a)
3041  if(iforce .or. (size(a) .lt. n)) then
3042  ! we need to reallocate
3043  if(icopy) then
3044  ! we must save a copy
3045  tmp => a
3046  nullify(a)
3047  else
3048  deallocate(a, stat=err)
3049  if(err .ne. 0) then
3050  call qrm_err_push(7, sub='qrm_prealloc_z',ied=(/err,0,0,0,0/))
3051  else
3052  call qrm_mem_upd(-int(n,8)*qrm_sizeof_z_)
3053  end if
3054  end if
3055  ! reallocate a
3056  allocate(a(n), stat=err)
3057  if(err .ne. 0) then
3058  call qrm_err_push(5,sub='qrm_palloc_z',ied=(/n,0,0,0,0/))
3059  else
3060  call qrm_mem_upd(+int(n,8)*qrm_sizeof_z_)
3061  end if
3062  else
3063  return
3064  end if
3065  else
3066  ! allocate a
3067  allocate(a(n), stat=err)
3068  if(err .ne. 0) then
3069  call qrm_err_push(5,sub='qrm_palloc_z',ied=(/n,0,0,0,0/))
3070  else
3071  call qrm_mem_upd(+int(n,8)*qrm_sizeof_z_)
3072  end if
3073  end if
3074 
3075  ! check if copy is to be done
3076  if(icopy) then
3077  do i=1, asize
3078  a(i) = tmp(i)
3079  end do
3080  deallocate(tmp, stat=err)
3081  if(err .ne. 0) then
3082  call qrm_err_push(7, sub='qrm_prealloc_z',ied=(/err,0,0,0,0/))
3083  else
3084  call qrm_mem_upd(-asize*qrm_sizeof_z_)
3085  end if
3086  end if
3087 
3088  return
3089 
3090  end subroutine qrm_prealloc_z
3091 
3092 
3099  subroutine qrm_prealloc_c(a, n, force, copy)
3100 
3101  complex(kind(1.e0)), pointer, dimension(:) :: a
3102  integer :: n
3103  logical, optional :: force, copy
3104 
3105  integer :: err=0, asize, i
3106  logical :: iforce, icopy
3107  complex(kind(1.e0)), pointer, dimension(:) :: tmp=>null()
3108 
3109  iforce=.false.
3110  if(present(force)) iforce=force
3111 
3112  ! if iforce=.true. we don't make any copies. Also, if a is not associated
3113  ! then there's nothing to copy.
3114  icopy = .false.
3115  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. associated(a))
3116 
3117  if(associated(a)) then
3118  ! a is associated
3119  asize = size(a)
3120  if(iforce .or. (size(a) .lt. n)) then
3121  ! we need to reallocate
3122  if(icopy) then
3123  ! we must save a copy
3124  tmp => a
3125  nullify(a)
3126  else
3127  deallocate(a, stat=err)
3128  if(err .ne. 0) then
3129  call qrm_err_push(7, sub='qrm_prealloc_c',ied=(/err,0,0,0,0/))
3130  else
3131  call qrm_mem_upd(-int(n,8)*qrm_sizeof_c_)
3132  end if
3133  end if
3134  ! reallocate a
3135  allocate(a(n), stat=err)
3136  if(err .ne. 0) then
3137  call qrm_err_push(5,sub='qrm_prealloc_c',ied=(/n,0,0,0,0/))
3138  else
3139  call qrm_mem_upd(+int(n,8)*qrm_sizeof_c_)
3140  end if
3141  else
3142  return
3143  end if
3144  else
3145  ! allocate a
3146  allocate(a(n), stat=err)
3147  if(err .ne. 0) then
3148  call qrm_err_push(5,sub='qrm_prealloc_c',ied=(/n,0,0,0,0/))
3149  else
3150  call qrm_mem_upd(+int(n,8)*qrm_sizeof_c_)
3151  end if
3152  end if
3153 
3154  ! check if copy is to be done
3155  if(icopy) then
3156  do i=1, asize
3157  a(i) = tmp(i)
3158  end do
3159  deallocate(tmp, stat=err)
3160  if(err .ne. 0) then
3161  call qrm_err_push(7, sub='qrm_prealloc_c',ied=(/err,0,0,0,0/))
3162  else
3163  call qrm_mem_upd(-asize*qrm_sizeof_c_)
3164  end if
3165  end if
3166 
3167  return
3168 
3169  end subroutine qrm_prealloc_c
3170 
3171 
3178  subroutine qrm_arealloc_z(a, n, force, copy)
3179 
3180  complex(kind(1.d0)), allocatable, dimension(:) :: a
3181  integer :: n
3182  logical, optional :: force, copy
3183 
3184  integer :: err=0, asize, i
3185  logical :: iforce, icopy
3186  complex(kind(1.d0)), allocatable, dimension(:) :: tmp
3187 
3188  iforce=.false.
3189  if(present(force)) iforce=force
3190 
3191  ! if iforce=.true. we don't make any copies. Also, if a is not allocated
3192  ! then there's nothing to copy.
3193  icopy = .false.
3194  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. allocated(a))
3195 
3196  if(allocated(a)) then
3197  ! a is allocated
3198  asize = size(a)
3199  if(iforce .or. (size(a) .lt. n)) then
3200  ! we need to reallocate
3201  if(.not. icopy) then
3202  deallocate(a, stat=err)
3203  if(err .ne. 0) then
3204  call qrm_err_push(7, sub='qrm_arealloc_z',ied=(/err,0,0,0,0/))
3205  else
3206  call qrm_mem_upd(-int(n,8)*qrm_sizeof_z_)
3207  end if
3208  end if
3209  ! allocate tmp
3210  allocate(tmp(n), stat=err)
3211  if(err .ne. 0) then
3212  call qrm_err_push(5,sub='qrm_arealloc_z',ied=(/n,0,0,0,0/))
3213  else
3214  call qrm_mem_upd(+int(n,8)*qrm_sizeof_z_)
3215  end if
3216  else
3217  return
3218  end if
3219  else
3220  ! allocate a
3221  allocate(tmp(n), stat=err)
3222  if(err .ne. 0) then
3223  call qrm_err_push(5,sub='qrm_arealloc_z',ied=(/n,0,0,0,0/))
3224  else
3225  call qrm_mem_upd(+int(n,8)*qrm_sizeof_z_)
3226  end if
3227  end if
3228 
3229  ! check if copy is to be done
3230  if(icopy) then
3231  do i=1, asize
3232  tmp(i) = a(i)
3233  end do
3234  deallocate(a, stat=err)
3235  if(err .ne. 0) then
3236  call qrm_err_push(7, sub='qrm_arealloc_z',ied=(/err,0,0,0,0/))
3237  else
3238  call qrm_mem_upd(-asize*qrm_sizeof_z_)
3239  end if
3240  end if
3241 
3242  call move_alloc(from=tmp, to=a)
3243 
3244  return
3245 
3246  end subroutine qrm_arealloc_z
3247 
3248 
3255  subroutine qrm_arealloc_c(a, n, force, copy)
3256 
3257  complex(kind(1.e0)), allocatable, dimension(:) :: a
3258  integer :: n
3259  logical, optional :: force, copy
3260 
3261  integer :: err=0, asize, i
3262  logical :: iforce, icopy
3263  complex(kind(1.e0)), allocatable, dimension(:) :: tmp
3264 
3265  iforce=.false.
3266  if(present(force)) iforce=force
3267 
3268  ! if iforce=.true. we don't make any copies. Also, if a is not allocated
3269  ! then there's nothing to copy.
3270  icopy = .false.
3271  if(present(copy)) icopy=(copy .and. (.not. iforce) .and. allocated(a))
3272 
3273  if(allocated(a)) then
3274  ! a is allocated
3275  asize = size(a)
3276  if(iforce .or. (size(a) .lt. n)) then
3277  ! we need to reallocate
3278  if(.not. icopy) then
3279  deallocate(a, stat=err)
3280  if(err .ne. 0) then
3281  call qrm_err_push(7, sub='qrm_arealloc_c',ied=(/err,0,0,0,0/))
3282  else
3283  call qrm_mem_upd(-int(n,8)*qrm_sizeof_c_)
3284  end if
3285  end if
3286  ! allocate tmp
3287  allocate(tmp(n), stat=err)
3288  if(err .ne. 0) then
3289  call qrm_err_push(5,sub='qrm_arealloc_c',ied=(/n,0,0,0,0/))
3290  else
3291  call qrm_mem_upd(+int(n,8)*qrm_sizeof_c_)
3292  end if
3293  else
3294  return
3295  end if
3296  else
3297  ! allocate a
3298  allocate(tmp(n), stat=err)
3299  if(err .ne. 0) then
3300  call qrm_err_push(5,sub='qrm_arealloc_c',ied=(/n,0,0,0,0/))
3301  else
3302  call qrm_mem_upd(+int(n,8)*qrm_sizeof_c_)
3303  end if
3304  end if
3305 
3306  ! check if copy is to be done
3307  if(icopy) then
3308  do i=1, asize
3309  tmp(i) = a(i)
3310  end do
3311  deallocate(a, stat=err)
3312  if(err .ne. 0) then
3313  call qrm_err_push(7, sub='qrm_arealloc_c',ied=(/err,0,0,0,0/))
3314  else
3315  call qrm_mem_upd(-asize*qrm_sizeof_c_)
3316  end if
3317  end if
3318 
3319  call move_alloc(from=tmp, to=a)
3320 
3321  return
3322 
3323  end subroutine qrm_arealloc_c
3324 
3325 
3328  function qrm_asize_c(a)
3329 
3330  implicit none
3331 
3332  integer :: qrm_asize_c
3333  complex(kind(1.e0)), allocatable :: a(:)
3334 
3335  if(allocated(a)) then
3336  ! a is allocated
3337  qrm_asize_c = size(a)
3338  else
3339  qrm_asize_c = 0
3340  end if
3341 
3342  return
3343 
3344  end function qrm_asize_c
3345 
3348  function qrm_asize_z(a)
3349 
3350  implicit none
3351 
3352  integer :: qrm_asize_z
3353  complex(kind(1.d0)), allocatable :: a(:)
3354 
3355  if(allocated(a)) then
3356  ! a is allocated
3357  qrm_asize_z = size(a)
3358  else
3359  qrm_asize_z = 0
3360  end if
3361 
3362  return
3363 
3364  end function qrm_asize_z
3365 
3366 
3369  function qrm_asize_2c(a)
3370 
3371  implicit none
3372 
3373  integer :: qrm_asize_2c
3374  complex(kind(1.e0)), allocatable :: a(:,:)
3375 
3376  if(allocated(a)) then
3377  ! a is allocated
3378  qrm_asize_2c = size(a)
3379  else
3380  qrm_asize_2c = 0
3381  end if
3382 
3383  return
3384 
3385  end function qrm_asize_2c
3386 
3389  function qrm_asize_2z(a)
3390 
3391  implicit none
3392 
3393  integer :: qrm_asize_2z
3394  complex(kind(1.d0)), allocatable :: a(:,:)
3395 
3396  if(allocated(a)) then
3397  ! a is allocated
3398  qrm_asize_2z = size(a)
3399  else
3400  qrm_asize_2z = 0
3401  end if
3402 
3403  return
3404 
3405  end function qrm_asize_2z
3406 
3407 
3408 
3411  function qrm_asize_3c(a)
3412 
3413  implicit none
3414 
3415  integer :: qrm_asize_3c
3416  complex(kind(1.e0)), allocatable :: a(:,:,:)
3417 
3418  if(allocated(a)) then
3419  ! a is allocated
3420  qrm_asize_3c = size(a)
3421  else
3422  qrm_asize_3c = 0
3423  end if
3424 
3425  return
3426 
3427  end function qrm_asize_3c
3428 
3429 
3432  function qrm_asize_3z(a)
3433 
3434  implicit none
3435 
3436  integer :: qrm_asize_3z
3437  complex(kind(1.d0)), allocatable :: a(:,:,:)
3438 
3439  if(allocated(a)) then
3440  ! a is allocated
3441  qrm_asize_3z = size(a)
3442  else
3443  qrm_asize_3z = 0
3444  end if
3445 
3446  return
3447 
3448  end function qrm_asize_3z
3449 
3450 ! ===========================================================================================
3451 
3452 
3453 
3456  function qrm_psize_i(a)
3457 
3458  implicit none
3459 
3460  integer :: qrm_psize_i
3461  integer, pointer :: a(:)
3462 
3463  if(associated(a)) then
3464  ! a is allocated
3465  qrm_psize_i = size(a)
3466  else
3467  qrm_psize_i = 0
3468  end if
3469 
3470  return
3471 
3472  end function qrm_psize_i
3473 
3474 
3477  function qrm_psize_s(a)
3478 
3479  implicit none
3480 
3481  integer :: qrm_psize_s
3482  real(kind(1.e0)), pointer :: a(:)
3483 
3484  if(associated(a)) then
3485  ! a is allocated
3486  qrm_psize_s = size(a)
3487  else
3488  qrm_psize_s = 0
3489  end if
3490 
3491  return
3492 
3493  end function qrm_psize_s
3494 
3495 
3496 
3499  function qrm_psize_c(a)
3500 
3501  implicit none
3502 
3503  integer :: qrm_psize_c
3504  complex(kind(1.e0)), pointer :: a(:)
3505 
3506  if(associated(a)) then
3507  ! a is allocated
3508  qrm_psize_c = size(a)
3509  else
3510  qrm_psize_c = 0
3511  end if
3512 
3513  return
3514 
3515  end function qrm_psize_c
3516 
3519  function qrm_psize_z(a)
3520 
3521  implicit none
3522 
3523  integer :: qrm_psize_z
3524  complex(kind(1.d0)), pointer :: a(:)
3525 
3526  if(associated(a)) then
3527  ! a is allocated
3528  qrm_psize_z = size(a)
3529  else
3530  qrm_psize_z = 0
3531  end if
3532 
3533  return
3534 
3535  end function qrm_psize_z
3536 
3539  function qrm_psize_d(a)
3540 
3541  implicit none
3542 
3543  integer :: qrm_psize_d
3544  real(kind(1.d0)), pointer :: a(:)
3545 
3546  if(associated(a)) then
3547  ! a is allocated
3548  qrm_psize_d = size(a)
3549  else
3550  qrm_psize_d = 0
3551  end if
3552 
3553  return
3554 
3555  end function qrm_psize_d
3556 
3557 
3558  subroutine qrm_get_mem_stats(totmem, maxmem)
3559  ! Function: qrm_get_mem_stats
3560  ! This subroutine returns stats on memory.
3561  !
3562  ! *Output*:
3563  ! totmem - the amount of memory currently allocated
3564  ! maxmem - the peak memory allocated
3565 
3566  integer(kind=8) :: totmem, maxmem
3567 
3568  totmem = qrm_tot_mem(0)
3569  maxmem = qrm_max_mem(0)
3570 
3571  return
3572 
3573  end subroutine qrm_get_mem_stats
3574 
3575 
3576 
3577 end module qrm_mem_mod
This module contains all the error management routines and data.
integer function qrm_asize_3d(a)
Generic interface for the qrm_adealloc_i, qrm_adealloc_2i, qrm_adealloc_s, qrm_adealloc_2s, qrm_adealloc_3s, qrm_adealloc_d, qrm_adealloc_2d, qrm_adealloc_3d, qrm_adealloc_c, qrm_adealloc_2c, qrm_adealloc_3c, qrm_adealloc_z, qrm_adealloc_2z, qrm_adealloc_3z, routines.
integer function qrm_asize_c(a)
integer function qrm_psize_c(a)
subroutine qrm_palloc_z_8(a, n, info)
subroutine qrm_palloc_2i(a, m, n, info)
subroutine qrm_aalloc_3s(a, m, n, k, info)
integer function qrm_asize_s(a)
integer function qrm_asize_2d(a)
subroutine qrm_palloc_2s(a, m, n, info)
subroutine qrm_palloc_2z(a, m, n, info)
subroutine qrm_palloc_i(a, n, info)
integer function qrm_asize_2z(a)
integer function qrm_psize_s(a)
subroutine qrm_palloc_i_8(a, n, info)
subroutine qrm_aalloc_z(a, n, lbnd, info)
subroutine qrm_aalloc_d(a, n, lbnd, info)
subroutine qrm_aalloc_2i(a, m, n, info)
subroutine qrm_palloc_d_8(a, n, info)
integer function qrm_asize_d(a)
subroutine qrm_aalloc_i(a, n, lbnd, info)
integer function qrm_psize_i(a)
subroutine qrm_aalloc_2z(a, m, n, info)
integer function qrm_psize_d(a)
subroutine qrm_palloc_z(a, n, info)
subroutine qrm_mem_upd(n)
updates memory statistics
subroutine qrm_get_mem_stats(totmem, maxmem)
integer function qrm_psize_z(a)
subroutine qrm_aalloc_3z(a, m, n, k, info)
subroutine qrm_palloc_s_8(a, n, info)
Generic interface for the qrm_psize_i qrm_psize_s qrm_psize_d qrm_psize_c qrm_psize_z, routines.
subroutine qrm_prealloc_s(a, n, force, copy)
integer function qrm_asize_3s(a)
subroutine qrm_prealloc_z(a, n, force, copy)
Generic interface for the qrm_aalloc_i, qrm_aalloc_2i, qrm_aalloc_s, qrm_aalloc_2s, qrm_aalloc_3s, qrm_aalloc_d, qrm_aalloc_2d, qrm_aalloc_3d, qrm_aalloc_c, qrm_aalloc_2c, qrm_aalloc_3c, qrm_aalloc_z, qrm_aalloc_2z, qrm_aalloc_3z, routines.
Definition: qrm_mem_mod.F90:78
subroutine qrm_aalloc_3c(a, m, n, k, info)
subroutine qrm_prealloc_d(a, n, force, copy)
subroutine qrm_palloc_2c(a, m, n, info)
integer function qrm_asize_z(a)
Generic interface for the qrm_pdealloc_i, qrm_pdealloc_2i, qrm_pdealloc_s, qrm_pdealloc_2s, qrm_pdealloc_d, qrm_pdealloc_2d, qrm_pdealloc_c, qrm_pdealloc_2c, qrm_pdealloc_z, qrm_pdealloc_2z, routines.
Definition: qrm_mem_mod.F90:98
Generic interface for the qrm_prealloc_i qrm_prealloc_s qrm_prealloc_d qrm_prealloc_c qrm_prealloc_z...
subroutine qrm_aalloc_2c(a, m, n, info)
subroutine qrm_arealloc_d(a, n, force, copy)
subroutine qrm_par_mem_init()
This routine has to be called at the beginning of a parallel section. Afterwards, each thread will up...
integer function qrm_asize_3z(a)
subroutine qrm_arealloc_s(a, n, force, copy)
subroutine qrm_palloc_s(a, n, info)
subroutine qrm_prealloc_c(a, n, force, copy)
integer function qrm_asize_i(a)
subroutine qrm_aalloc_2s(a, m, n, info)
Generic interface for the qrm_asize_i, qrm_asize_s, qrm_asize_2s, qrm_asize_3s, qrm_asize_d, qrm_asize_2d, qrm_asize_3d, qrm_asize_c, qrm_asize_2c, qrm_asize_3c, qrm_asize_z, qrm_asize_2z, qrm_asize_3z routines.
subroutine qrm_palloc_c(a, n, info)
subroutine qrm_aalloc_c(a, n, lbnd, info)
subroutine qrm_par_mem_finalize()
subroutine qrm_aalloc_2d(a, m, n, info)
subroutine qrm_arealloc_i(a, n, force, copy)
integer function qrm_asize_2s(a)
Generic interface for the qrm_arealloc_i qrm_arealloc_s qrm_arealloc_d qrm_arealloc_c qrm_arealloc_z...
integer function qrm_asize_2c(a)
This module implements the memory handling routines. Pretty mucch allocations and deallocations...
Definition: qrm_mem_mod.F90:38
subroutine qrm_arealloc_c(a, n, force, copy)
subroutine qrm_palloc_c_8(a, n, info)
Generic interface for the qrm_palloc_i, qrm_palloc_2i, qrm_palloc_s, qrm_palloc_2s, qrm_palloc_d, qrm_palloc_2d, qrm_palloc_c, qrm_palloc_2c, qrm_palloc_z, qrm_palloc_2z, routines.
Definition: qrm_mem_mod.F90:57
subroutine qrm_palloc_d(a, n, info)
int i
Definition: secs.c:40
subroutine qrm_aalloc_3d(a, m, n, k, info)
subroutine qrm_aalloc_s(a, n, lbnd, info)
integer function qrm_asize_3c(a)
subroutine qrm_err_push(code, sub, ied, aed)
This subroutine pushes an error on top of the stack.
subroutine qrm_arealloc_z(a, n, force, copy)
subroutine qrm_palloc_2d(a, m, n, info)
subroutine qrm_prealloc_i(a, n, force, copy)