QR_MUMPS
dqrm_residual_orth.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 !! ##############################################################################################
34 
35 #include "qrm_common.h"
36 
38 
48 subroutine dqrm_residual_orth2d(qrm_mat, r, nrm)
50  use qrm_error_mod
51  use qrm_mem_mod
52  use dqrm_utils_mod
53  implicit none
54 
55  type(dqrm_spmat_type) :: qrm_mat
56  real(kind(1.d0)) :: r(:,:)
57  real(kind(1.d0)) :: nrm(:)
58 
59  real(kind(1.d0)), allocatable :: tmp(:,:)
60  real(kind(1.d0)), allocatable :: rnrm(:)
61  real(kind(1.d0)) :: anrm
62 
63  ! error management
64  integer :: err_act
65  character(len=*), parameter :: name='qrm_residual_orth'
66 
67  call qrm_err_act_save(err_act)
68 
69  call dqrm_check_spmat(qrm_mat)
70  __qrm_check_ret(name,'qrm_check_spmat',9999)
71 
72  call qrm_aalloc(tmp, qrm_mat%n, size(r,2))
73  call qrm_aalloc(rnrm, size(r,2))
74 
75  ! compute A'*r
76  call qrm_matmul(qrm_mat, 't', 1.d0, r, 0.d0, tmp)
77 
78  call qrm_vecnrm(r , qrm_mat%m, '2', rnrm)
79  call qrm_vecnrm(tmp, qrm_mat%n, '2', nrm)
80  call qrm_matnrm(qrm_mat, 'f', anrm)
81  nrm = nrm/(rnrm*anrm)
82 
83  call qrm_adealloc(tmp)
84  call qrm_adealloc(rnrm)
85 
86  call qrm_err_act_restore(err_act)
87  return
88 
89 9999 continue ! error management
90  call qrm_err_act_restore(err_act)
91  if(err_act .eq. qrm_abort_) then
92  call qrm_err_check()
93  end if
94  return
95 
96 end subroutine dqrm_residual_orth2d
97 
99 
109 subroutine dqrm_residual_orth1d(qrm_mat, r, nrm)
111  use qrm_error_mod
112  use qrm_mem_mod
113  use dqrm_utils_mod
114  implicit none
115 
116  type(dqrm_spmat_type) :: qrm_mat
117  real(kind(1.d0)) :: r(:)
118  real(kind(1.d0)) :: nrm
119 
120  real(kind(1.d0)), allocatable :: tmp(:)
121  real(kind(1.d0)) :: rnrm
122  real(kind(1.d0)) :: anrm
123 
124  ! error management
125  integer :: err_act
126  character(len=*), parameter :: name='qrm_residual_orth'
127 
128  call qrm_err_act_save(err_act)
129 
130  call dqrm_check_spmat(qrm_mat)
131  __qrm_check_ret(name,'qrm_check_spmat',9999)
132 
133  call qrm_aalloc(tmp, qrm_mat%n)
134 
135  ! compute A'*r
136  call qrm_matmul(qrm_mat, 't', 1.d0, r, 0.d0, tmp)
137 
138  call qrm_vecnrm(r, qrm_mat%m, '2', rnrm)
139  call qrm_vecnrm(tmp, qrm_mat%n, '2', nrm)
140  call qrm_matnrm(qrm_mat, 'f', anrm)
141 
142  nrm = nrm/(rnrm*anrm)
143  call qrm_adealloc(tmp)
144 
145  call qrm_err_act_restore(err_act)
146  return
147 
148 9999 continue ! error management
149  call qrm_err_act_restore(err_act)
150  if(err_act .eq. qrm_abort_) then
151  call qrm_err_check()
152  end if
153  return
154 
155 end subroutine dqrm_residual_orth1d
156 
157 
158 
159 
160 
162 
173 subroutine dqrm_residual_and_orth2d(qrm_mat, b, x, nrm)
175  use qrm_error_mod
176  use qrm_mem_mod
177  use dqrm_utils_mod
178  implicit none
179 
180  type(dqrm_spmat_type) :: qrm_mat
181  real(kind(1.d0)) :: b(:,:), x(:,:)
182  real(kind(1.d0)) :: nrm(:)
183 
184  real(kind(1.d0)), allocatable :: tmp(:,:)
185  real(kind(1.d0)), allocatable :: rnrm(:)
186 
187  ! error management
188  integer :: err_act
189  character(len=*), parameter :: name='qrm_residual_orth'
190 
191  call qrm_err_act_save(err_act)
192 
193  call dqrm_check_spmat(qrm_mat)
194  __qrm_check_ret(name,'qrm_check_spmat',9999)
195 
196  ! compute the residual
197  call qrm_matmul(qrm_mat, 'n', -1.d0, x, 1.d0, b)
198 
199  call qrm_aalloc(tmp , qrm_mat%n, size(x,2))
200  call qrm_aalloc(rnrm, size(x,2))
201 
202  ! compute A'*r
203  call qrm_matmul(qrm_mat, 't', 1.d0, b, 0.d0, tmp)
204 
205  call qrm_vecnrm(b, qrm_mat%m, '2', rnrm)
206  call qrm_vecnrm(tmp, qrm_mat%n, '2', nrm)
207  nrm = nrm/rnrm
208 
209  call qrm_adealloc(tmp)
210 
211  call qrm_err_act_restore(err_act)
212  return
213 
214 9999 continue ! error management
215  call qrm_err_act_restore(err_act)
216  if(err_act .eq. qrm_abort_) then
217  call qrm_err_check()
218  end if
219  return
220 
221 end subroutine dqrm_residual_and_orth2d
222 
223 
225 
236 subroutine dqrm_residual_and_orth1d(qrm_mat, b, x, nrm)
238  use qrm_error_mod
239  use qrm_mem_mod
240  use dqrm_utils_mod
241  implicit none
242 
243  type(dqrm_spmat_type) :: qrm_mat
244  real(kind(1.d0)) :: b(:), x(:)
245  real(kind(1.d0)) :: nrm
246 
247  real(kind(1.d0)), allocatable :: tmp(:)
248  real(kind(1.d0)) :: rnrm
249 
250  ! error management
251  integer :: err_act
252  character(len=*), parameter :: name='qrm_residual_orth'
253 
254  call qrm_err_act_save(err_act)
255 
256  call dqrm_check_spmat(qrm_mat)
257  __qrm_check_ret(name,'qrm_check_spmat',9999)
258 
259  ! compute the residual
260  call qrm_matmul(qrm_mat, 'n', -1.d0, x, 1.d0, b)
261 
262  call qrm_aalloc(tmp, qrm_mat%n)
263 
264  ! compute A'*r
265  call qrm_matmul(qrm_mat, 't', 1.d0, b, 0.d0, tmp)
266 
267  call qrm_vecnrm(b, qrm_mat%m, '2', rnrm)
268  call qrm_vecnrm(tmp, qrm_mat%n, '2', nrm)
269  nrm = nrm/rnrm
270 
271  call qrm_adealloc(tmp)
272 
273  call qrm_err_act_restore(err_act)
274  return
275 
276 9999 continue ! error management
277  call qrm_err_act_restore(err_act)
278  if(err_act .eq. qrm_abort_) then
279  call qrm_err_check()
280  end if
281  return
282 
283 end subroutine dqrm_residual_and_orth1d
This module contains generic interfaces for a number of auxiliary tools.
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.
Generic interface for the ::dqrm_matmul2d and ::dqrm_matmul1d routines.
subroutine dqrm_residual_and_orth1d(qrm_mat, b, x, nrm)
This routine computes the scaled norm of the product A'*r.
subroutine qrm_err_act_save(err_act)
Saves a copy of the qrm_err_act variable.
Generic interface for the ::dqrm_vecnrm2d and ::dqrm_vecnrm1d routines.
subroutine dqrm_residual_orth1d(qrm_mat, r, nrm)
This routine computes the scaled norm of the product A'*r.
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...
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
integer, parameter qrm_abort_
Possible actions to be performed upon detection of an error.
subroutine dqrm_residual_and_orth2d(qrm_mat, b, x, nrm)
This routine computes the scaled norm of the product A'*r.
subroutine qrm_err_check()
This subroutine checks the errors stack. If something is found all the entries in the stack are poppe...
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.
subroutine dqrm_residual_orth2d(qrm_mat, r, nrm)
This routine computes the scaled norm of the product A'*r for multiple residuals. ...
This module implements the memory handling routines. Pretty mucch allocations and deallocations...
Definition: qrm_mem_mod.F90:38
subroutine qrm_err_act_restore(err_act)
Restores the value of the qrm_err_act variable.