From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001
From: Joseph Hunkeler <jhunkeler@gmail.com>
Date: Wed, 8 Jul 2015 20:46:52 -0400
Subject: Initial commit

---
 pkg/tbtables/fitsio/ftxmsg.f | 47 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 47 insertions(+)
 create mode 100644 pkg/tbtables/fitsio/ftxmsg.f

(limited to 'pkg/tbtables/fitsio/ftxmsg.f')

diff --git a/pkg/tbtables/fitsio/ftxmsg.f b/pkg/tbtables/fitsio/ftxmsg.f
new file mode 100644
index 00000000..bd5b9006
--- /dev/null
+++ b/pkg/tbtables/fitsio/ftxmsg.f
@@ -0,0 +1,47 @@
+C------------------------------------------------------------------------------
+        subroutine ftxmsg(action,text)
+
+C       get, put, or clear the error message stack 
+
+        integer action
+        character*(*) text
+
+        integer nbuff,i
+        parameter (nbuff=50)
+        character*80 txbuff(nbuff)
+        save txbuff
+        data txbuff/nbuff * ' '/
+
+        if (action .eq. -1)then
+
+C           get error message from top of stack and shift the stack up one
+            text=txbuff(1)
+            do 10 i=1,nbuff-1
+                txbuff(i) = txbuff(i+1)
+ 10         continue
+            txbuff(nbuff)=' '
+
+        else if (action .eq. 1)then
+
+C           put error message onto stack.
+            do 20 i=1,nbuff
+                if (txbuff(i) .eq. ' ')then
+                   txbuff(i)=text
+                   return
+                end if
+20          continue
+C           stack is full so discard oldest message
+            do 25 i=1,nbuff-1
+                txbuff(i) = txbuff(i+1)
+25          continue
+            txbuff(nbuff)=text
+
+        else if (action .eq. 0)then
+
+C           clear the error message stack
+            do 30 i=1,nbuff
+                txbuff(i) = ' '
+30          continue
+
+        end if
+        end
-- 
cgit