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 real(kind(1.d0)),
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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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=
'dqrm_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(
'("dqrm_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(
'("dqrm_get_r -- The R matrix contains empty rows")')
This module contains all the error management routines and data.
subroutine dqrm_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...
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 dqrm_get_r(qrm_mat, r)
Generif interface for the ::dqrm_spmat_alloc routine.
subroutine dqrm_pgetr(qrm_spmat, string, rval)
Gets the values of a real control parameter. This is the dual of the ::dqrm_psetr routine; the parame...
subroutine dqrm_pgetii(qrm_spmat, string, ival)
Gets the values of an integer control parameter. This is the dual of the ::dqrm_pseti routine; the pa...
subroutine dqrm_cntl_init(qrm_spmat)
This subroutine initializes a qrm_spmat_type instance setting default values into the control paramet...
Generif interface for the ::dqrm_pgeti, ::dqrm_pgetr and.
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.
Generif interface for the ::dqrm_pseti, ::dqrm_psetr and.
Generif interface for the ::dqrm_spmat_copy routine.
This module contains the definition of the analysis data type.
Generif interface for the ::dqrm_spmat_destroy routine.
This module contains the definition of the basic sparse matrix type and of the associated methods...
subroutine dqrm_pgeti(qrm_spmat, string, ival)
Gets the values of an integer control parameter. This is the dual of the ::dqrm_pseti routine; the pa...
subroutine qrm_err_check()
This subroutine checks the errors stack. If something is found all the entries in the stack are poppe...
The data structure meant to store all the results of the factorization phase.
subroutine qrm_adata_destroy(adata)
Frees an qrm_adata_type instance.
This module contains the definition of all the data related to the factorization phase.
Generif interface for the ::dqrm_spmat_convert routine.
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.
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.
subroutine dqrm_spmat_destroy(qrm_spmat, all)
This subroutine destroyes a qrm_spmat instance.
subroutine dqrm_pseti(qrm_spmat, string, ival)
This subroutine is meant to set the integer control parameters.
Generic interface for the qrm_prealloc_i qrm_prealloc_s qrm_prealloc_d qrm_prealloc_c qrm_prealloc_z...
subroutine dqrm_spmat_convert(in_mat, out_mat, fmt, values)
This subroutine converts an input matrix into a different storage format. Optionally the values may b...
Generif interface for the ::dqrm_cntl_init routine.
subroutine dqrm_spmat_init(qrm_spmat)
This subroutine initializes a qrm_spmat_type instance setting default values into the control paramet...
subroutine dqrm_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...
Generif interface for the ::dqrm_spmat_init routine.
This type defines the data structure used to store a matrix.
subroutine dqrm_check_spmat(qrm_spmat, op)
Check the compatibility and correctness of icntl and rcntl parameters.
This type defines a data structure containing all the data related to a front.
This module implements the memory handling routines. Pretty mucch allocations and deallocations...
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 dqrm_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 dqrm_fdata_destroy(qrm_fdata)
Destroys a dqrm_fdata_type instance.
subroutine qrm_err_push(code, sub, ied, aed)
This subroutine pushes an error on top of the stack.
subroutine dqrm_spmat_alloc(qrm_spmat, nz, m, n, fmt)
This subroutine allocates memory for a sparse matrix.
Generif interface for the ::dqrm_spmat_alloc routine.
subroutine dqrm_psetr(qrm_spmat, string, rval)
This subroutine is meant to set the real control parameters.
subroutine qrm_err_act_save(err_act)
Saves a copy of the qrm_err_act variable.