35 #include "qrm_common.h" 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)
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
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
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
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
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)
823 subroutine dqrm_pseti(qrm_spmat, string, ival)
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
910 subroutine dqrm_psetr(qrm_spmat, string, rval)
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
1007 subroutine dqrm_pgeti(qrm_spmat, string, ival)
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)
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 1119 subroutine dqrm_pgetr(qrm_spmat, string, rval)
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_)
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_))
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")')
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_spmat_alloc(qrm_spmat, nz, m, n, fmt)
This subroutine allocates memory for a sparse matrix.
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.
Generif interface for the ::dqrm_spmat_alloc routine.
This module contains the interfaces of all non-typed routines.
subroutine dqrm_cntl_init(qrm_spmat)
This subroutine initializes a qrm_spmat_type instance setting default values into the control paramet...
subroutine qrm_err_push(code, sub, ied, aed)
This subroutine pushes an error on top of the stack.
Generif interface for the ::dqrm_pgeti, ::dqrm_pgetr and.
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 dqrm_fdata_destroy(qrm_fdata)
Destroys a dqrm_fdata_type instance.
Generif interface for the ::dqrm_pseti, ::dqrm_psetr and.
Generif interface for the ::dqrm_spmat_copy routine.
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...
This module contains the definition of the analysis data type.
Generif interface for the ::dqrm_spmat_destroy routine.
subroutine dqrm_pseti(qrm_spmat, string, ival)
This subroutine is meant to set the integer control parameters.
subroutine qrm_err_act_save(err_act)
Saves a copy of the qrm_err_act variable.
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_pgetr(qrm_spmat, string, rval)
Gets the values of a real control parameter. This is the dual of the ::dqrm_psetr routine; the parame...
The data structure meant to store all the results of the factorization phase.
This module contains all the error management routines and data.
This module contains the definition of the basic sparse matrix type and of the associated methods...
subroutine dqrm_spmat_init(qrm_spmat)
This subroutine initializes a qrm_spmat_type instance setting default values into the control paramet...
subroutine qrm_adata_destroy(adata)
Frees an qrm_adata_type instance.
Generif interface for the ::dqrm_spmat_convert routine.
The main data type for the analysis phase.
subroutine dqrm_get_r(qrm_mat, r)
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 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...
integer, parameter qrm_abort_
Possible actions to be performed upon detection of an error.
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.
Generic interface for the qrm_prealloc_i qrm_prealloc_s qrm_prealloc_d qrm_prealloc_c qrm_prealloc_z...
subroutine qrm_err_check()
This subroutine checks the errors stack. If something is found all the entries in the stack are poppe...
Generif interface for the ::dqrm_cntl_init routine.
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 contains the definition of all the data related to the factorization phase.
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 implements the memory handling routines. Pretty mucch allocations and deallocations...
This module contains various string handling routines.
subroutine qrm_err_act_restore(err_act)
Restores the value of the qrm_err_act variable.
subroutine dqrm_psetr(qrm_spmat, string, rval)
This subroutine is meant to set the real control parameters.
Generif interface for the ::dqrm_spmat_alloc routine.
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...