Initial commit

1 files changed, 297 insertions, 0 deletions

diff --git a/pkg/tbtables/fitsio/ftgthd.f b/pkg/tbtables/fitsio/ftgthd.f
new file mode 100644
index 00000000..ee4a3aa6
--- /dev/null
+++ b/pkg/tbtables/fitsio/ftgthd.f
@@ -0,0 +1,297 @@
+C--------------------------------------------------------------------------
+        subroutine ftgthd(tmplat,card,hdtype,status)
+
+C       'Get Template HeaDer'
+C       parse a template header line and create a formated
+C       80-character string which is suitable for appending to a FITS header 
+
+C       tmplat  c  input header template string
+C       card    c  returned 80-character string = FITS header record
+C       hdtype  i  type of operation that should be applied to this keyword:
+C                      -2  =  modify the name of a keyword; the new name
+C                             is returned in characters 41:48 of CARD.
+C                      -1  =  delete this keyword 
+C                       0  =  append (if it doesn't already exist) or 
+C                             overwrite this keyword (if it does exist)
+C                       1  =  append this comment keyword ('HISTORY', 
+C                             'COMMENT', or blank keyword name) 
+C                       2  =  this is an END record; do not append it
+C                             to a FITS header! 
+C       status  i  returned error status 
+C               if a positive error status is returned then the first 
+C               80 characters of the offending input line are returned
+C               by the CARD parameter
+
+        integer hdtype,status,tstat
+        character*(*) tmplat
+        character*80 card
+        integer i1,i2,com1,strend,length
+        character inline*100,keynam*8,ctemp*80,qc*1
+        logical number
+        double precision dvalue
+
+        if (status .gt. 0)return
+        card=' '
+        hdtype=0
+
+        inline=tmplat
+
+C       test if columns 1-8 are blank; if so, this is a FITS comment record;
+C       just copy it verbatim to the FITS header
+        if (inline(1:8) .eq. ' ')then
+                card=inline(1:80)
+                go to 999
+        end if
+
+C       parse the keyword name = the first token separated by a space or a '='
+C       1st locate the first nonblank character (we know it is not all blank):
+        i1=0
+20      i1=i1+1
+C       test for a leading minus sign which flags name of keywords to be deleted
+        if (inline(i1:i1) .eq. '-')then
+                hdtype=-1
+C               test for a blank keyword name
+                if (inline(i1+1:i1+8) .eq. '        ')then
+                       card=' '
+                       i2=i1+9
+                       go to 35
+                end if
+                go to 20
+        else if (inline(i1:i1) .eq. ' ')then
+                go to 20
+        end if
+
+C       now find the last character of the keyword name
+        i2=i1
+30      i2=i2+1
+        if (inline(i2:i2) .ne. ' ' .and. inline(i2:i2) .ne. '=')go to 30
+
+C       test for legal keyword name length (max 8 characters)
+        if (i2-i1 .gt. 8)then
+                status=207
+                card=inline(1:80)
+                go to 999
+        end if
+
+        keynam=inline(i1:i2-1)
+
+C       convert to upper case and test for illegal characters in keyword name
+        call ftupch(keynam)
+        call fttkey(keynam,status)
+        if (status .gt. 0)then
+                card=inline(1:80)
+                go to 999
+        end if
+
+C       if this is the 'END' then this is the end of the input file
+        if (keynam .eq. 'END     ')goto 998
+
+C       copy the keyword name to the output record string
+        card(1:8)=keynam
+
+C       jump if this is just the name of keyword to be deleted
+        if (hdtype .lt. 0)go to 35
+
+C       test if this is a COMMENT or HISTORY record
+        if (keynam .eq. 'COMMENT' .or. keynam .eq. 'HISTORY')then
+C               append next 72 characters from input line to output record
+                card(9:80)=inline(i2:)
+                hdtype=1
+                go to 999
+        else
+C               this keyword must have a value, so append the '= ' to output
+                card(9:10)='= '
+        end if
+
+C       now locate the value token in the input line.  If it includes
+C       embedded spaces it must be enclosed in single quotes. The value must
+C       be separated by at least one blank space from the comment string
+
+C       find the first character of the value string
+35      i1=i2-1
+40      i1=i1+1
+        if (i1 .gt. 100)then
+C               no value is present in the input line
+                if (hdtype .lt. 0)then
+C                       this is normal; just quit
+                        go to 999
+                else
+                        status=204
+                        card=inline(1:80)
+                        go to 999
+                end if
+        end if
+        if (hdtype .lt. 0 .and. inline(i1:i1) .eq. '=')then
+C               The leading minus sign, plus the presence of an equal sign
+C               between the first 2 tokens is taken to mean that the
+C               keyword with the first token name is to be deleted.
+                go to 999
+        else if (inline(i1:i1).eq. ' ' .or.inline(i1:i1).eq. '=')then 
+                go to 40
+        end if
+
+C       is the value a quoted string?
+        if (inline(i1:i1) .eq. '''')then
+C               find the closing quote 
+                i2=i1
+50              i2=i2+1
+                if (i2 .gt. 100)then
+C                       error: no closing quote on value string
+                        status=205
+                        card=inline(1:80)
+            call ftpmsg('Keyword value string has no closing quote:')
+            call ftpmsg(card)
+                        go to 999
+                end if
+                if (inline(i2:i2) .eq. '''')then
+                        if (inline(i2+1:i2+1) .eq. '''')then
+C                               ignore 2 adjacent single quotes
+                                i2=i2+1
+                                go to 50
+                        end if
+                else
+                        go to 50
+                end if
+C               value string can't be more than 70 characters long (cols 11-80)
+                length=i2-i1
+                if (length .gt. 69)then
+                        status=205
+                        card=inline(1:80)
+            call ftpmsg('Keyword value string is too long:')
+            call ftpmsg(card)
+                        go to 999
+                end if
+
+C               append value string to output, left justified in column 11
+                card(11:11+length)=inline(i1:i2)
+C               com1 is the starting position for the comment string
+                com1=max(32,13+length)
+
+C               FITS string must be at least 8 characters long
+                if (length .lt. 9)then
+                        card(11+length:11+length)=' '
+                        card(20:20)=''''
+                end if
+        else
+C               find the end of the value field
+                i2=i1
+60              i2=i2+1
+                if (i2 .gt. 100)then
+C                       error: value string is too long
+                        status=205
+                        card=inline(1:80)
+            call ftpmsg('Keyword value string is too long:')
+            call ftpmsg(card)
+                        go to 999
+                end if
+                if (inline(i2:i2) .ne. ' ')go to 60
+
+C               test if this is a logical value
+                length=i2-i1
+                if (length .eq. 1 .and. (inline(i1:i1) .eq. 'T'
+     &              .or. inline(i1:i1) .eq. 'F'))then
+                        card(30:30)=inline(i1:i1)
+                        com1=32
+                else
+C                   test if this is a numeric value; try reading it as 
+C                   double precision value; if it fails, it must be a string
+                    number=.true.
+                    tstat=status
+                    call ftc2dd(inline(i1:i2-1),dvalue,status)
+                    if (status .gt. 0)then
+                        status=tstat
+                        number=.false.
+                    else
+C                       check the first character to make sure this is a number
+C                       since certain non-numeric character strings pass the
+C                       above test on SUN machines.
+                        qc=inline(i1:i1)
+                        if (qc .ne. '+' .and. qc .ne. '-' .and. qc .ne.
+     &                  '.' .and. (qc .lt. '0' .or. qc .gt. '9'))then
+C                              This really was not a number!
+                               number=.false.
+                        end if
+                    end if
+
+                    if (number)then
+                        if (length .le. 20)then
+C                               write the value right justified in col 30
+                                card(31-length:30)=inline(i1:i2-1)
+                                com1=32
+                        else
+C                               write the long value left justified in col 11
+                                card(11:10+length)=inline(i1:i2-1)
+                                com1=max(32,12+length)
+                        end if
+                    else
+C                       value is a character string datatype
+                        card(11:11)=''''
+                        strend=11+length
+                        card(12:strend)=inline(i1:i2-1)
+C                       need to expand any embedded single quotes into 2 quotes
+                        i1=11
+70                      i1=i1+1
+                        if (i1 .gt. strend) go to 80
+                        if (card(i1:i1) .eq. '''')then
+                                i1=i1+1
+                                if (card(i1:i1) .ne. '''')then
+C                                       have to insert a 2nd quote into string
+                                        ctemp=card(i1:strend)
+                                        card(i1:i1)=''''
+                                        strend=strend+1
+                                        i1=i1+1
+                                        card(i1:strend)=ctemp
+                                end if
+                        end if
+                        go to 70
+
+80                      strend=max(20,strend+1)
+                        card(strend:strend)=''''
+                        com1=max(32,strend+2)
+                    end if
+                end if
+        end if
+        
+C       check if this was a request to modify a keyword name
+        if (hdtype .eq. -1)then
+                hdtype = -2
+C               the keyword value is really the new keyword name
+C               return the new name in characters 41:48 of the output card
+                keynam=card(12:19)
+C               convert to upper case and test for illegal characters in name
+                call ftupch(keynam)
+                call fttkey(keynam,status)
+                if (status .gt. 0)then
+                        card=inline(1:80)
+                        go to 999
+                else
+                        card(9:80)=' '
+                        card(41:48)=keynam
+                        go to 999
+                end if
+        end if
+
+C       is there room for a comment string?
+        if (com1 .lt. 79)then
+C               now look for the beginning of the comment string
+                i1=i2
+90              i1=i1+1
+C               if no comment field then just quit
+                if (i1 .gt. 100)go to 999
+                if (inline(i1:i1) .eq. ' ')go to 90
+
+C               append the comment field
+                if (inline(i1:i1) .eq. '/')then
+                        card(com1:80)=inline(i1:)
+                else
+                        card(com1:80)='/ '//inline(i1:)
+                end if
+        end if
+
+        go to 999
+
+C       end of input file was detected
+998     hdtype=2
+
+999     continue
+        end