35 #include "qrm_common.h"
143 integer :: icntl(20)=0
154 real(kind(1.d0)) :: rcntl(10)=0.d0
162 integer(kind=8) :: gstats(10)=0
164 integer,
pointer,
dimension(:) :: iptr => null()
166 integer,
pointer,
dimension(:) :: jptr => null()
168 integer,
pointer,
dimension(:) :: irn => null()
170 integer,
pointer,
dimension(:) :: jcn => null()
172 _qrm_data,
pointer,
dimension(:) :: val => null()
181 integer,
pointer,
dimension(:) :: cperm_in => null()
189 character(len=3) :: fmt=
'coo'
222 integer,
intent(in) :: nz, m, n
223 character,
intent(in) :: fmt*(*)
228 character(len=*),
parameter :: name=
'_qrm_spmat_alloc'
233 __qrm_prnt_dbg(
'("Allocating Matrix")')
236 if(fmt .eq.
'coo')
then
240 __qrm_check_ret(name,
'qrm_palloc',9999)
241 else if(fmt .eq.
'csr')
then
245 __qrm_check_ret(name,
'qrm_palloc',9999)
246 else if(fmt .eq.
'csc')
then
250 __qrm_check_ret(name,
'qrm_palloc',9999)
265 if(err_act .eq. qrm_abort_)
then
283 character(LEN=10) :: str
289 nullify(qrm_spmat%iptr, qrm_spmat%jptr, qrm_spmat%irn, qrm_spmat%jcn, &
290 & qrm_spmat%val, qrm_spmat%cperm_in)
308 character(LEN=10) :: str
319 qrm_spmat%icntl(qrm_nlz_) = 8
320 qrm_spmat%icntl(qrm_cnode_) = 1
323 qrm_spmat%rcntl(qrm_amalgth_) = 0.05
324 qrm_spmat%rcntl(qrm_rweight_) = 0.001
325 qrm_spmat%fmt =
'coo'
327 call get_environment_variable(name=
"QRM_NUM_THREADS",value=str, status=ierr)
329 qrm_spmat%icntl(qrm_nthreads_) = 1
331 read(str,*)qrm_spmat%icntl(qrm_nthreads_)
360 character,
intent(in) :: fmt*(*)
361 logical,
optional :: values
364 character(len=*),
parameter :: name=
'_qrm_spmat_convert'
368 select case(in_mat%fmt)
390 out_mat%icntl = in_mat%icntl
391 out_mat%rcntl = in_mat%rcntl
398 if(err_act .eq. qrm_abort_)
then
423 logical,
optional :: values
425 integer,
allocatable :: work(:)
426 logical :: ivalues, ob
427 integer ::
i, j, idx, k, m, n
430 character(len=*),
parameter :: name=
'_qrm_coo_to_csc'
434 if(present(values))
then
445 __qrm_check_ret(name,
'qrm_alloc',9999)
457 if((j.gt.0) .and. (j.le. n) .and. (
i.gt.0) .and. (
i.le. m) )
then
466 __qrm_prnt_dbg(
'("** Out-of-bounds coefficients present **")')
472 out_mat%jptr(j) = out_mat%jptr(j-1)+work(j-1)
484 if((j.le.0) .or. (j.gt. n) .or. (
i.le.0) .or. (
i.gt. m) ) cycle
485 idx = out_mat%jptr(j)+work(j)
487 out_mat%val(idx) = in_mat%val(k)
494 if((j.le.0) .or. (j.gt. n) .or. (
i.le.0) .or. (
i.gt. m) ) cycle
495 idx = out_mat%jptr(j)+work(j)
502 __qrm_check_ret(name,
'qrm_adelloc',9999)
506 out_mat%nz = in_mat%nz
514 if(err_act .eq. qrm_abort_)
then
536 logical,
optional :: values
538 integer,
allocatable :: work(:)
540 logical :: ivalues, ob
541 integer ::
i, j, idx, ii, m, n
544 character(len=*),
parameter :: name=
'_qrm_csc_to_csr'
548 if(present(values))
then
564 __qrm_check_ret(name,
'qrm_alloc',9999)
569 do ii= in_mat%jptr(j), in_mat%jptr(j+1)-1
571 if((
i.gt.0) .and. (
i.le.m))
then
580 __qrm_prnt_dbg(
'("** Out-of-bounds coefficients present **")')
586 out_mat%iptr(j) = out_mat%iptr(j-1)+work(j-1)
596 do ii= in_mat%jptr(j), in_mat%jptr(j+1)-1
598 if((
i.le.0) .or. (
i.gt.m)) cycle
599 idx = out_mat%iptr(
i)+work(
i)
601 out_mat%val(idx) = in_mat%val(ii)
607 do ii= in_mat%jptr(j), in_mat%jptr(j+1)-1
609 if((
i.le.0) .or. (
i.gt.m)) cycle
610 idx = out_mat%iptr(
i)+work(
i)
618 __qrm_check_ret(name,
'qrm_adelloc',9999)
622 out_mat%nz = in_mat%nz
630 if(err_act .eq. qrm_abort_)
then
656 logical,
optional :: values
658 logical :: ivalues=.true.
661 character(len=*),
parameter :: name=
'_qrm_spmat_copy'
667 if(present(values)) ivalues=values
669 select case(in_mat%fmt)
673 __qrm_check_ret(name,
'qrm_prelloc',9999)
676 out_mat%jptr(
i) = in_mat%jptr(
i)
679 out_mat%irn(
i) = in_mat%irn(
i)
683 __qrm_check_ret(name,
'qrm_prealloc',9999)
684 out_mat%val = in_mat%val
689 __qrm_check_ret(name,
'qrm_prealloc',9999)
691 out_mat%jcn(
i) = in_mat%jcn(
i)
692 out_mat%irn(
i) = in_mat%irn(
i)
696 __qrm_check_ret(name,
'qrm_realloc',9999)
697 out_mat%val = in_mat%val
706 out_mat%nz = in_mat%nz
707 out_mat%fmt = in_mat%fmt
708 out_mat%icntl = in_mat%icntl
709 out_mat%rcntl = in_mat%rcntl
716 if(err_act .eq. qrm_abort_)
then
735 logical,
optional :: all
740 character(len=*),
parameter :: name=
'_qrm_spmat_destroy'
744 if(present(all))
then
757 __qrm_check_ret(name,
'qrm_pdealloc',9999)
766 __qrm_check_ret(name,name,9999)
768 __qrm_check_ret(name,name,9999)
775 if(err_act .eq. qrm_abort_)
then
830 character(len=*) :: string
833 character(len=len(string)) :: istring
836 character(len=*),
parameter :: name=
'_qrm_pseti'
841 if(index(istring,
'qrm_ordering') .eq. 1)
then
843 else if (index(istring,
'qrm_minamalg') .eq. 1)
then
845 else if (index(istring,
'qrm_nb') .eq. 1)
then
846 qrm_spmat%icntl(
qrm_nb_) = ival
848 __qrm_prnt_msg(
'("Warning: qrm_ib is being set equal to qrm_nb")')
851 else if (index(istring,
'qrm_ib') .eq. 1)
then
852 qrm_spmat%icntl(
qrm_ib_) = ival
854 __qrm_prnt_msg(
'("Warning: qrm_nb is being set equal to qrm_ib")')
857 else if (index(istring,
'qrm_rhsnb') .eq. 1)
then
859 else if (index(istring,
'qrm_nthreads') .eq. 1)
then
860 qrm_spmat%icntl(qrm_nthreads_) = ival
861 else if (index(istring,
'qrm_rhsnthreads') .eq. 1)
then
863 else if (index(istring,
'qrm_keeph') .eq. 1)
then
869 else if (index(istring,
'qrm_sing') .eq. 1)
then
875 else if (index(istring,
'qrm_nlz') .eq. 1)
then
876 qrm_spmat%icntl(qrm_nlz_) = ival
877 else if (index(istring,
'qrm_cnode') .eq. 1)
then
878 qrm_spmat%icntl(qrm_cnode_) = ival
889 if(err_act .eq. qrm_abort_)
then
918 character(len=*) :: string
919 real(kind(1.d0)) :: rval
921 character(len=len(string)) :: istring
924 character(len=*),
parameter :: name=
'_qrm_psetr'
930 if(index(istring,
'qrm_amalgth') .eq. 1)
then
931 qrm_spmat%rcntl(qrm_amalgth_) = rval
932 else if(index(istring,
'qrm_rweight') .eq. 1)
then
933 qrm_spmat%rcntl(qrm_rweight_) = rval
944 if(err_act .eq. qrm_abort_)
then
1014 character(len=*) :: string
1017 character(len=len(string)) :: istring
1018 integer(kind=8) :: iival
1021 character(len=*),
parameter :: name=
'_qrm_pgeti'
1026 __qrm_check_ret(name,
'qrm_pgetii',9999)
1035 if(err_act .eq. qrm_abort_)
then
1053 character(len=* ) :: string
1054 integer(kind=8) :: ival
1056 character(len=len(string)) :: istring
1059 character(len=*),
parameter :: name=
'_qrm_pgetii'
1065 if(index(istring,
'qrm_ordering') .eq. 1)
then
1067 else if (index(istring,
'qrm_minamalg') .eq. 1)
then
1069 else if (index(istring,
'qrm_nb') .eq. 1)
then
1070 ival = qrm_spmat%icntl(
qrm_nb_)
1071 else if (index(istring,
'qrm_ib') .eq. 1)
then
1072 ival = qrm_spmat%icntl(
qrm_ib_)
1073 else if (index(istring,
'qrm_rhsnb') .eq. 1)
then
1075 else if (index(istring,
'qrm_nthreads') .eq. 1)
then
1076 ival = qrm_spmat%icntl(qrm_nthreads_)
1077 else if (index(istring,
'qrm_rhsnthreads') .eq. 1)
then
1079 else if (index(istring,
'qrm_keeph') .eq. 1)
then
1081 else if (index(istring,
'qrm_sing') .eq. 1)
then
1083 else if (index(istring,
'qrm_e_nnz_r') .eq. 1)
then
1085 else if (index(istring,
'qrm_e_nnz_h') .eq. 1)
then
1087 else if (index(istring,
'qrm_e_facto_flops') .eq. 1)
then
1089 else if (index(istring,
'qrm_nnz_r') .eq. 1)
then
1091 else if (index(istring,
'qrm_nnz_h') .eq. 1)
then
1093 else if (index(istring,
'qrm_facto_flops') .eq. 1)
then
1105 if(err_act .eq. qrm_abort_)
then
1127 character(len=*) :: string
1128 real(kind(1.d0)) :: rval
1130 character(len=len(string)) :: istring
1133 character(len=*),
parameter :: name=
'_qrm_pgetr'
1139 if(index(istring,
'qrm_amalgth') .eq. 1)
then
1140 rval = qrm_spmat%rcntl(qrm_amalgth_)
1151 if(err_act .eq. qrm_abort_)
then
1219 integer,
optional :: op
1225 character(len=*),
parameter :: name=
'_qrm_check_spmat'
1229 if(present(op))
then
1235 if((qrm_spmat%m .lt. 0) .or. (qrm_spmat%n .lt. 0) .or. &
1236 & (qrm_spmat%nz .lt. 0) .or. &
1237 & (qrm_spmat%nz .gt. (int(qrm_spmat%n,kind=8)*int(qrm_spmat%m,kind=8))))
then
1238 call
qrm_err_push(29, name,ied=(/qrm_spmat%m,qrm_spmat%n,qrm_spmat%nz,0,0/))
1243 if((iop.eq.qrm_allop_) .or. (iop.eq.qrm_analyse_))
then
1258 select case(qrm_spmat%icntl(
qrm_nb_))
1269 select case(qrm_spmat%icntl(
qrm_ib_))
1281 if(err_act .eq. qrm_abort_)
then
1300 integer :: cnt, fcnt, f, jp, pk, j, k, n, c, rbcnt, rtcnt,
i, rps, du, eu
1303 r%m =
size(qrm_mat%adata%rperm)
1304 r%n =
size(qrm_mat%adata%cperm)
1311 r%adata%cperm = qrm_mat%adata%cperm
1314 rbcnt = min(r%m,r%n)+1
1317 do f = 1, qrm_mat%adata%nnodes
1318 front => qrm_mat%fdata%front_list(f)
1319 rps = rps + front%npiv + front%m-front%ne
1320 r%adata%rperm(rtcnt:rtcnt+front%npiv-1) = front%rows(1:front%npiv)
1321 r%adata%rperm(rbcnt:rbcnt + front%m-front%ne-1) = front%rows(front%ne+1:front%m)
1322 rtcnt = rtcnt+front%npiv
1323 rbcnt = rbcnt + front%m-front%ne
1326 outer:
do jp = 1, front%npiv, front%nb
1327 pk = min(front%nb, front%npiv-jp+1)
1328 if(pk .le. 0)
exit outer
1330 inner:
do j = jp, jp+pk-1, front%ib
1331 k = min(front%ib, jp+pk - j)
1332 if(k .le. 0)
exit inner
1336 r%irn(cnt:cnt+c-1) = front%rows(j:j+c-1)
1337 r%jcn(cnt:cnt+c-1) = front%cols(j+c-1)
1338 r%val(cnt:cnt+c-1) = front%r(fcnt:fcnt+c-1)
1344 r%irn(cnt:cnt+k-1) = front%rows(j:j+k-1)
1345 r%jcn(cnt:cnt+k-1) = front%cols(j+c-1)
1346 r%val(cnt:cnt+k-1) = front%r(fcnt:fcnt+k-1)
1356 if(rbcnt .ne. r%m+1)
then
1357 __qrm_prnt_dbg(
'("_qrm_get_r -- The matrix contains empty rows")')
1358 r%adata%rperm(rbcnt:r%m) = qrm_mat%adata%rperm(rbcnt:r%m)
1361 if(rtcnt.lt.min(r%m,r%n))
then
1362 __qrm_prnt_err(
'("_qrm_get_r -- The R matrix contains empty rows")')
Generif interface for the ::_qrm_spmat_destroy routine.
This module contains all the error management routines and data.
subroutine _qrm_spmat_convert(in_mat, out_mat, fmt, values)
This subroutine converts an input matrix into a different storage format. Optionally the values may b...
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.
subroutine _qrm_spmat_alloc(qrm_spmat, nz, m, n, fmt)
This subroutine allocates memory for a sparse matrix.
This module contains the definition of all the data related to the factorization phase.
Generif interface for the ::_qrm_cntl_init routine.
subroutine _qrm_spmat_copy(in_mat, out_mat, values)
This subroutine makes a copy of a matrix. Optionally the values may be ignored (this comes handy duri...
subroutine _qrm_get_r(qrm_mat, r)
subroutine _qrm_psetr(qrm_spmat, string, rval)
This subroutine is meant to set the real control parameters.
subroutine _qrm_spmat_destroy(qrm_spmat, all)
This subroutine destroyes a qrm_spmat instance.
This module contains the interfaces of all non-typed routines.
subroutine qrm_err_act_restore(err_act)
Restores the value of the qrm_err_act variable.
This module contains the definition of the analysis data type.
subroutine _qrm_pseti(qrm_spmat, string, ival)
This subroutine is meant to set the integer control parameters.
Generif interface for the ::_qrm_spmat_alloc routine.
Generif interface for the ::_qrm_spmat_copy routine.
subroutine _qrm_fdata_destroy(qrm_fdata)
Destroys a _qrm_fdata_type instance.
subroutine qrm_err_check()
This subroutine checks the errors stack. If something is found all the entries in the stack are poppe...
subroutine qrm_adata_destroy(adata)
Frees an qrm_adata_type instance.
subroutine _qrm_pgeti(qrm_spmat, string, ival)
Gets the values of an integer control parameter. This is the dual of the ::_qrm_pseti routine; the pa...
The main data type for the analysis phase.
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.
subroutine _qrm_coo_to_csc(in_mat, out_mat, values)
This subroutine converts a COO matrix into a CSC matrix. Optionally the values may be ignored (this c...
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.
Generic interface for the qrm_prealloc_i qrm_prealloc_s qrm_prealloc_d qrm_prealloc_c qrm_prealloc_z...
subroutine _qrm_pgetr(qrm_spmat, string, rval)
Gets the values of a real control parameter. This is the dual of the ::_qrm_psetr routine; the parame...
subroutine _qrm_spmat_init(qrm_spmat)
This subroutine initializes a qrm_spmat_type instance setting default values into the control paramet...
subroutine _qrm_csc_to_csr(in_mat, out_mat, values)
This subroutine converts a CSC matrix into a CSR matrix. Optionally the values may be ignored (this c...
Generif interface for the ::_qrm_spmat_convert routine.
This type defines the data structure used to store a matrix.
The data structure meant to store all the results of the factorization phase.
subroutine _qrm_cntl_init(qrm_spmat)
This subroutine initializes a qrm_spmat_type instance setting default values into the control paramet...
subroutine _qrm_check_spmat(qrm_spmat, op)
Check the compatibility and correctness of icntl and rcntl parameters.
This module contains the definition of the basic sparse matrix type and of the associated methods...
Generif interface for the ::_qrm_pseti, ::_qrm_psetr and.
Generif interface for the ::_qrm_spmat_alloc routine.
subroutine _qrm_pgetii(qrm_spmat, string, ival)
Gets the values of an integer control parameter. This is the dual of the ::_qrm_pseti routine; the pa...
This module implements the memory handling routines. Pretty mucch allocations and deallocations...
Generif interface for the ::_qrm_pgeti, ::_qrm_pgetr and.
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.
This module contains various string handling routines.
subroutine qrm_err_push(code, sub, ied, aed)
This subroutine pushes an error on top of the stack.
This type defines a data structure containing all the data related to a front.
Generif interface for the ::_qrm_spmat_init routine.
subroutine qrm_err_act_save(err_act)
Saves a copy of the qrm_err_act variable.