← Back to branch summary

~ubuntu-branches/debian/sid/abinit/sid

« back to all changes in this revision

Viewing changes to src/11util/matcginv.F90

  • Committer: Bazaar Package Importer
  • Author(s): Christophe Prud'homme
  • Date: 2007-09-14 13:05:00 UTC
  • Revision ID: james.westby@ubuntu.com-20070914130500-1kzh2mrgo6ir4b6i
Tags: upstream-5.3.4.dfsg
Import upstream version 5.3.4.dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/11util/matcginv.F90
 
1
!{\src2tex{textfont=tt}}
 
2
!!****f* ABINIT/matcginv
 
3
!! NAME
 
4
!! matcginv
 
5
!!
 
6
!! FUNCTION
 
7
!! Invert a general matrix of complex elements.
 
8
!!
 
9
!! COPYRIGHT
 
10
!! Copyright (C) 2001-2007 ABINIT group (GMR)
 
11
!! This file is distributed under the terms of the
 
12
!! GNU General Public License, see ~abinit/COPYING
 
13
!! or http://www.gnu.org/copyleft/gpl.txt .
 
14
!!
 
15
!! INPUTS
 
16
!! lda=leading dimension of complex matrix a
 
17
!! n=size of complex matrix a
 
18
!! a=matrix of complex elements
 
19
!! OUTPUT
 
20
!! a=inverse of a input matrix
 
21
!! SIDE EFFECTS
 
22
!! a(lda,n)= array of complex elements, input, inverted at output
 
23
!!
 
24
!!
 
25
!! PARENTS
 
26
!!      screening
 
27
!!
 
28
!! CHILDREN
 
29
!!      cbgmdi,cbgmlu,cgeicd,cgetrf,cgetri,leave_new,wrtout
 
30
!!
 
31
!! SOURCE
 
32
 
 
33
#if defined HAVE_CONFIG_H
 
34
#include "config.h"
 
35
#endif
 
36
 
 
37
subroutine matcginv(a,lda,n)
 
38
 
 
39
 use defs_basis
 
40
 
 
41
!This section has been created automatically by the script Abilint (TD). Do not modify these by hand.
 
42
#ifdef HAVE_FORTRAN_INTERFACES
 
43
 use interfaces_01manage_mpi
 
44
#endif
 
45
!End of the abilint section
 
46
 
 
47
 implicit none
 
48
 
 
49
!Arguments ------------------------------------
 
50
!scalars
 
51
 integer,intent(in) :: lda,n
 
52
!arrays
 
53
 complex,intent(inout) :: a(lda,n)
 
54
 
 
55
!Local variables-------------------------------
 
56
!scalars
 
57
 integer :: ierr,istat,nwork
 
58
 character(len=500) :: message
 
59
!arrays
 
60
 integer :: ipvt(n)
 
61
 complex,allocatable :: work(:)
 
62
!no_abirules
 
63
#if defined HAVE_IBM_ESSL_OLD
 
64
 complex :: rcond
 
65
 complex :: det(2)
 
66
#else
 
67
 real(dp) :: det
 
68
 complex :: cdet
 
69
#endif
 
70
 
 
71
! *************************************************************************
 
72
#ifdef VMS
 
73
!DEC$ ATTRIBUTES ALIAS:'CGETRI' :: cgetri
 
74
!DEC$ ATTRIBUTES ALIAS:'CGETRF' :: cgetrf
 
75
#endif
 
76
 
 
77
#if defined HAVE_IBM_ESSL_OLD
 
78
 nwork=200*n
 
79
#else
 
80
 nwork=n
 
81
#endif
 
82
 
 
83
 allocate(work(nwork))
 
84
 
 
85
#if defined HAVE_IBM_ESSL_OLD
 
86
 
 
87
 call cgeicd(a,lda,n,0,rcond,det,work,nwork)
 
88
 if(abs(rcond)==zero) then
 
89
  write(message, '(10a)' ) ch10,&
 
90
& ' matcginv : BUG -',ch10,&
 
91
& '  The matrix that has been passed in argument of this subroutine',ch10,&
 
92
& '  is probably either singular or nearly singular.',ch10,&
 
93
& '  The ESSL routine cgeicd failed.',ch10,&
 
94
& '  Action : Contact ABINIT group '
 
95
  call wrtout(6,message,'COLL')
 
96
  call leave_new('COLL')
 
97
 end if
 
98
 
 
99
#elif defined HAVE_NEC_ASL
 
100
 
 
101
 call cbgmlu(a,lda,n,ipvt,ierr)
 
102
 if(ierr /= 0) then
 
103
  write(message, '(10a)' ) ch10,&
 
104
& ' matcginv : BUG -',ch10,&
 
105
& '  The matrix that has been passed in argument of this subroutine',ch10,&
 
106
& '  is probably either singular or nearly singular.',ch10,&
 
107
& '  The ASL routine cbgmlu failed.',ch10,&
 
108
& '  Action : Contact ABINIT group '
 
109
  call wrtout(6,message,'COLL')
 
110
  call leave_new('COLL')
 
111
 end if
 
112
 call cbgmdi(a,lda,n,ipvt,cdet,det,-1,work,ierr)
 
113
 if(ierr /= 0) then
 
114
  write(message, '(10a)' ) ch10,&
 
115
& ' matcginv : BUG -',ch10,&
 
116
& '  The matrix that has been passed in argument of this subroutine',ch10,&
 
117
& '  is probably either singular or nearly singular.',ch10,&
 
118
& '  The ASL routine dbgmdi failed.',ch10,&
 
119
& '  Action : Contact ABINIT group '
 
120
  call wrtout(6,message,'COLL')
 
121
  call leave_new('COLL')
 
122
 end if
 
123
 
 
124
#else
 
125
 
 
126
 call cgetrf(n,n,a,lda,ipvt,ierr)
 
127
 if(ierr /= 0) then
 
128
  write(message, '(10a)' ) ch10,&
 
129
& ' matcginv : BUG -',ch10,&
 
130
& '  The matrix that has been passed in argument of this subroutine',ch10,&
 
131
& '  is probably either singular or nearly singular.',ch10,&
 
132
& '  The LAPACK routine cgetrf failed.',ch10,&
 
133
& '  Action : Contact ABINIT group '
 
134
  call wrtout(6,message,'COLL')
 
135
  call leave_new('COLL')
 
136
 end if
 
137
 call cgetri(n,a,n,ipvt,work,n,ierr)
 
138
 if(ierr /= 0) then
 
139
  write(message, '(10a)' ) ch10,&
 
140
& ' matcginv : BUG -',ch10,&
 
141
& '  The matrix that has been passed in argument of this subroutine',ch10,&
 
142
& '  is probably either singular or nearly singular.',ch10,&
 
143
& '  The LAPACK routine cgetri failed.',ch10,&
 
144
& '  Action : Contact ABINIT group '
 
145
  call wrtout(6,message,'COLL')
 
146
  call leave_new('COLL')
 
147
 end if
 
148
 
 
149
#endif
 
150
!DEBUG
 
151
!call printcm(a,n,n)
 
152
!ENDDEBUG
 
153
 deallocate(work)
 
154
 
 
155
end subroutine matcginv
 
156
!!***