From 04b3175abc4f75f688266a48807e7767688437be Mon Sep 17 00:00:00 2001
From: schnetter <schnetter@b716e942-a2de-43ad-8f52-f3dfe468e4e7>
Date: Wed, 12 Jan 2005 22:49:20 +0000
Subject: Add optional arguments to return an error code

git-svn-id: http://svn.einsteintoolkit.org/cactus/EinsteinUtils/TGRtensor/trunk@18 b716e942-a2de-43ad-8f52-f3dfe468e4e7
---
 src/matdet.F90 | 13 +++++++-----
 src/matinv.F90 | 65 ++++++++++++++++++++++++++++++++++++----------------------
 2 files changed, 48 insertions(+), 30 deletions(-)

diff --git a/src/matdet.F90 b/src/matdet.F90
index 27d452e..3ac9226 100644
--- a/src/matdet.F90
+++ b/src/matdet.F90
@@ -11,24 +11,27 @@ module matdet
   
 contains
   
-  subroutine calc_symdet4 (g4, dtg4)
-    CCTK_REAL, intent(in)  :: g4(4,4)
-    CCTK_REAL, intent(out) :: dtg4
+  subroutine calc_symdet4 (g4, dtg4, lerr)
+    CCTK_REAL,           intent(in)  :: g4(4,4)
+    CCTK_REAL,           intent(out) :: dtg4
+    logical,   optional, intent(out) :: lerr
     CCTK_REAL :: tmp(4,4)
     integer   :: ipiv(4)
     integer   :: info
     integer   :: nperms
     integer   :: i
-    character :: msg*1000
+    character :: msg*100
     
     tmp = g4
     call sytrf (4, 4, tmp, 4, ipiv, info)
     
     if (info < 0) then
        write (msg, '("Error in call to SYTRF, info=",i4)') info
-       call CCTK_WARN (1, trim(msg))
+       call CCTK_WARN (1, msg)
     end if
     
+    if (present(lerr)) lerr = info /= 0
+    
     if (info > 0) then
        dtg4 = 0
        return
diff --git a/src/matinv.F90 b/src/matinv.F90
index 24bed20..9a95e86 100644
--- a/src/matinv.F90
+++ b/src/matinv.F90
@@ -17,12 +17,13 @@ module matinv
   
 contains
   
-  subroutine calc_posinv3 (g3, gu3)
-    CCTK_REAL, intent(in)  :: g3(3,3)
-    CCTK_REAL, intent(out) :: gu3(3,3)
+  subroutine calc_posinv3 (g3, gu3, lerr)
+    CCTK_REAL,           intent(in)  :: g3(3,3)
+    CCTK_REAL,           intent(out) :: gu3(3,3)
+    logical,   optional, intent(out) :: lerr
     CCTK_REAL :: tmp(3,3)
     integer   :: info
-    character :: msg*1000
+    character :: msg*100
     
     tmp = g3
     gu3 = delta3
@@ -30,17 +31,20 @@ contains
     
     if (info /= 0) then
        write (msg, '("Error in call to POSV, info=",i4)') info
-       call CCTK_WARN (1, trim(msg))
+       call CCTK_WARN (1, msg)
     end if
+    
+    if (present(lerr)) lerr = info /= 0
   end subroutine calc_posinv3
   
-  subroutine calc_syminv3 (g3, gu3)
-    CCTK_REAL, intent(in)  :: g3(3,3)
-    CCTK_REAL, intent(out) :: gu3(3,3)
+  subroutine calc_syminv3 (g3, gu3, lerr)
+    CCTK_REAL,           intent(in)  :: g3(3,3)
+    CCTK_REAL,           intent(out) :: gu3(3,3)
+    logical,   optional, intent(out) :: lerr
     CCTK_REAL :: tmp(3,3)
     integer   :: ipiv(3)
     integer   :: info
-    character :: msg*1000
+    character :: msg*100
     
     integer, parameter :: lwork = 1000
     CCTK_REAL :: work(lwork)
@@ -51,17 +55,20 @@ contains
     
     if (info /= 0) then
        write (msg, '("Error in call to SYSV, info=",i4)') info
-       call CCTK_WARN (1, trim(msg))
+       call CCTK_WARN (1, msg)
     end if
+    
+    if (present(lerr)) lerr = info /= 0
   end subroutine calc_syminv3
   
-  subroutine calc_inv3 (g3, gu3)
-    CCTK_REAL, intent(in)  :: g3(3,3)
-    CCTK_REAL, intent(out) :: gu3(3,3)
+  subroutine calc_inv3 (g3, gu3, lerr)
+    CCTK_REAL,           intent(in)  :: g3(3,3)
+    CCTK_REAL,           intent(out) :: gu3(3,3)
+    logical,   optional, intent(out) :: lerr
     CCTK_REAL :: tmp(3,3)
     integer   :: ipiv(3)
     integer   :: info
-    character :: msg*1000
+    character :: msg*100
     
     tmp = g3
     gu3 = delta3
@@ -69,19 +76,22 @@ contains
     
     if (info /= 0) then
        write (msg, '("Error in call to GESV, info=",i2)') info
-       call CCTK_WARN (1, trim(msg))
+       call CCTK_WARN (1, msg)
     end if
+    
+    if (present(lerr)) lerr = info /= 0
   end subroutine calc_inv3
   
   
   
-  subroutine calc_syminv4 (g4, gu4)
-    CCTK_REAL, intent(in)  :: g4(0:3,0:3)
-    CCTK_REAL, intent(out) :: gu4(0:3,0:3)
+  subroutine calc_syminv4 (g4, gu4, lerr)
+    CCTK_REAL,           intent(in)  :: g4(0:3,0:3)
+    CCTK_REAL,           intent(out) :: gu4(0:3,0:3)
+    logical,   optional, intent(out) :: lerr
     CCTK_REAL :: tmp(0:3,0:3)
     integer   :: ipiv(0:3)
     integer   :: info
-    character :: msg*1000
+    character :: msg*100
     
     integer, parameter :: lwork = 1000
     CCTK_REAL :: work(lwork)
@@ -92,17 +102,20 @@ contains
     
     if (info /= 0) then
        write (msg, '("Error in call to SYSV, info=",i4)') info
-       call CCTK_WARN (1, trim(msg))
+       call CCTK_WARN (1, msg)
     end if
+    
+    if (present(lerr)) lerr = info /= 0
   end subroutine calc_syminv4
   
-  subroutine calc_inv4 (g4, gu4)
-    CCTK_REAL, intent(in)  :: g4(0:3,0:3)
-    CCTK_REAL, intent(out) :: gu4(0:3,0:3)
+  subroutine calc_inv4 (g4, gu4, lerr)
+    CCTK_REAL,           intent(in)  :: g4(0:3,0:3)
+    CCTK_REAL,           intent(out) :: gu4(0:3,0:3)
+    logical,   optional, intent(out) :: lerr
     CCTK_REAL :: tmp(0:3,0:3)
     integer   :: ipiv(0:3)
     integer   :: info
-    character :: msg*1000
+    character :: msg*100
     
     tmp = g4
     gu4 = delta4
@@ -110,8 +123,10 @@ contains
     
     if (info /= 0) then
        write (msg, '("Error in call to GESV, info=",i2)') info
-       call CCTK_WARN (1, trim(msg))
+       call CCTK_WARN (1, msg)
     end if
+    
+    if (present(lerr)) lerr = info /= 0
   end subroutine calc_inv4
   
 end module matinv
-- 
cgit v1.2.3