aboutsummaryrefslogtreecommitdiff
path: root/pkg/tbtables/fitsio/ftkeyn.f
blob: 8f020b946918d068eb31728d650a528e728506b6 (plain) (blame)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
C--------------------------------------------------------------------------
        subroutine ftkeyn(keywrd,nseq,keyout,status)

C       Make a keyword name by concatinating the root name and a 
C       sequence number

C       keywrd  c  root keyword name
C       nseq    i  sequence number 
C       OUTPUT PARAMETERS:
C       keyout  c  output concatinated keyword name
C       status  i  output error status (0 = ok)
C
C       written by Wm Pence, HEASARC/GSFC, February 1991

        character*(*) keywrd
        integer nseq,status,nspace,i
        character keyout*8,value*20

        keyout=keywrd

C       find end of keyword string
        nspace=1
        do 10 i=1,8
                if (keyout(i:i) .eq. ' ')go to 15
                nspace=nspace+1
10      continue
15      continue

C       append sequence number to keyword root only if there is room
        if (nseq .lt. 0)then
C               illegal value
                go to 900
        else if (nseq .lt. 10 .and. nspace .le. 8)then
                write(keyout(nspace:nspace),1001,err=900)nseq
        else if (nseq .lt. 100 .and. nspace .le. 7)then
                write(keyout(nspace:nspace+1),1002,err=900)nseq
        else if (nseq .lt. 1000 .and. nspace .le. 6)then
                write(keyout(nspace:nspace+2),1003,err=900)nseq
        else if (nseq .lt. 10000 .and. nspace .le. 5)then
                write(keyout(nspace:nspace+3),1004,err=900)nseq
        else if (nseq .lt. 100000 .and. nspace .le. 4)then
                write(keyout(nspace:nspace+4),1005,err=900)nseq
        else if (nseq .lt. 1000000 .and. nspace .le. 3)then
                write(keyout(nspace:nspace+5),1006,err=900)nseq
        else if (nseq .lt. 10000000 .and. nspace .le. 2)then
                write(keyout(nspace:nspace+6),1007,err=900)nseq
        else
C               number too big to fit in keyword
                go to 900
        end if

1001    format(i1)
1002    format(i2)
1003    format(i3)
1004    format(i4)
1005    format(i5)
1006    format(i6)
1007    format(i7)

        return
C       come here if error concatinating the seq. no. to the root string
900     continue

        if (status .gt. 0)return
        status=206
        write(value,1008)nseq
1008    format(i20)
        call ftpmsg('Could not concatinate the integer '//value//
     & ' to the root keyword named: '//keyout)
        end