DOUG 0.2

# SpMtx_arrange_qs.F90

Go to the documentation of this file.
00001 ! DOUG - Domain decomposition On Unstructured Grids
00002 ! Copyright (C) 1998-2006 Faculty of Computer Science, University of Tartu and
00003 ! Department of Mathematics, University of Bath
00004 !
00005 ! This library is free software; you can redistribute it and/or
00006 ! modify it under the terms of the GNU Lesser General Public
00008 ! version 2.1 of the License, or (at your option) any later version.
00009 !
00010 ! This library is distributed in the hope that it will be useful,
00011 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
00012 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00013 ! Lesser General Public License for more details.
00014 !
00015 ! You should have received a copy of the GNU Lesser General Public
00016 ! License along with this library; if not, write to the Free Software
00017 ! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
00018 ! or contact the authors (University of Tartu, Faculty of Computer Science, Chair
00019 ! of Distributed Systems, Liivi 2, 50409 Tartu, Estonia, http://dougdevel.org,
00020 ! mailto:info(at)dougdevel.org)
00021
00022 !!----------------------------------------------------------
00023 !!Simple sparse matrix arrangement using quicksort algorithm
00024 !!----------------------------------------------------------
00025 !module SpMtx_arrange_qs
00026
00027 !  use RealKind
00028 !  use SpMtx_class
00029
00030 !  Contains
00031
00032   function sm_elem_order(M, k1, k2, prim_i) result(res)
00033     type(SpMtx), intent(in) :: M
00034     integer, intent(in)        :: k1, k2
00035     integer                    :: res
00036     logical, optional          :: prim_i
00037
00038     if (present(prim_i) .AND. prim_i) then
00039       if (M%indi(k1) < M%indi(k2)) then
00040         res = -1
00041       else if (M%indi(k1) == M%indi(k2)) then
00042         if (M%indj(k1) < M%indj(k2)) then
00043           res = -1
00044         else if (M%indj(k1) == M%indj(k2)) then
00045           res = 0
00046         else
00047           res = 1
00048         endif
00049       else
00050         res = 1
00051       endif
00052     else
00053       if (M%indj(k1) < M%indj(k2)) then
00054         res = -1
00055       else if (M%indj(k1) == M%indj(k2)) then
00056         if (M%indi(k1) < M%indi(k2)) then
00057           res = -1
00058         else if (M%indi(k1) == M%indi(k2)) then
00059           res = 0
00060         else
00061           res = 1
00062         endif
00063       else
00064         res = 1
00065       endif
00066     endif
00067   end function sm_elem_order
00068
00069   subroutine SpMtx_swapElems(M, k1, k2)
00070     type(SpMtx), intent(inout) :: M
00071     integer, intent(in)           :: k1, k2
00072     real(kind=rk)                 :: tval
00073     integer                       :: tindi, tindj
00074
00075     tval = M%val(k1)
00076     M%val(k1) = M%val(k2)
00077     M%val(k2) = tval
00078
00079     tindi = M%indi(k1)
00080     M%indi(k1) = M%indi(k2)
00081     M%indi(k2) = tindi
00082
00083     tindj = M%indj(k1)
00084     M%indj(k1) = M%indj(k2)
00085     M%indj(k2) = tindj
00086
00087   end subroutine SpMtx_swapElems
00088
00089   recursive subroutine quick_arrange(M, l, r)
00090     type(SpMtx), intent(inout) :: M
00091     integer, intent(in)           :: l, r
00092     integer                       :: i, j
00093     logical                       :: arr_by_i
00094
00095     if (M%arrange_type == 0) return
00096
00097     arr_by_i = (M%arrange_type == 1)
00098
00099     i = l - 1
00100     j = r
00101
00102     if (r <= l) return
00103
00104     do while( .TRUE.)
00105       i = i + 1
00106       do while(sm_elem_order(M, i, r, arr_by_i) < 0)
00107         i = i + 1
00108       end do
00109       j = j - 1
00110       do while(sm_elem_order(M, r, j, arr_by_i) < 0)
00111         if (j == l) exit
00112         j = j - 1
00113       end do
00114       if (i >= j) exit
00115       call SpMtx_swapElems(M, i, j)
00116     end do
00117     call SpMtx_swapElems(M, i, r)
00118     call quick_arrange(M, l, i - 1)
00119     call quick_arrange(M, i + 1, r)
00120   end subroutine quick_arrange
00121
00122   subroutine SpMtx_arrangeQS(M, type_col)
00123     Implicit None
00124     Type(SpMtx), intent(in out) :: M
00125     logical, optional, intent(in)  :: type_col
00126     logical                        :: pr_type_col
00127     integer                        :: i, max_el, k, ind, M_ind
00128
00129     if (present(type_col)) then
00130       pr_type_col = type_col
00131     else
00132       pr_type_col = .FALSE.
00133     end if
00134
00135
00136     if (pr_type_col) then !!!columns
00137       max_el = M%ncols !maxval(M%indj)     !Number of columns
00138       if (M%arrange_type == 2) return
00139       if (M%arrange_type /= 0) deallocate(M%M_bound)
00140       M%arrange_type = 2
00141     else !!!rows
00142       max_el = M%nrows !maxval(M%indi)     !Number of rows
00143       if (M%arrange_type == 1) return
00144       if (M%arrange_type /= 0) deallocate(M%M_bound)
00145       M%arrange_type = 1
00146     end if
00147     allocate(M%M_bound(0:max_el))
00148
00149     call quick_arrange(M, 1, M%nnz)
00150
00151     M%M_bound = 0
00152
00153     do k = 1, M%nnz
00154       if (pr_type_col) then
00155         M%M_bound(M%indj(k)) = k + 1
00156       else
00157         M%M_bound(M%indi(k)) = k + 1
00158       endif
00159     end do
00160
00161     M%M_bound(0) = 1
00162
00163   end subroutine SpMtx_arrangeQS
00164 !end module SpMtx_arrange_qs
00165
00166 !----------------------------------------------------------------------
00167 !\$Log: SpMtx_arrange_qs.f90,v \$
00168 !Revision 1.5  2004/05/14 15:40:46  smirme
00169 !Added a faster sparse_ab subroutine.
00170 !
00171 !Revision 1.4  2004/04/23 13:18:26  smirme
00172 !Added wrapper for SpMtx_arrange to simplify switching between different algorithms.
00173 !FIxed a bug affecting the choice of plot area.
00174 !Simplified switching between different test grids.
00175 !
00176 !Revision 1.3  2004/04/16 05:37:09  smirme
00177 !Fixed bug in interp_op, added amg_plot, changed SpMtx_AB to use arranged sparse matrices
00178 !
00179 !Revision 1.2  2003/12/02 07:58:54  smirme
00180 !Fixed a mistake concerning m_bounds
00181 !
00182 !Revision 1.1  2003/12/01 17:35:10  smirme
00183 !Added ILU decomposer and a modified pcg for using any preconditioner
00184 !
00185 !----------------------------------------------------------------------