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
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
C--------------------------------------------------------------------------
subroutine ftkshf(iunit,colmin,colmax,incre,status)
C shift the index value on any existing column keywords
C This routine will modify the name of any keyword that begins with 'T'
C and has an index number in the range COLMIN - COLMAX, inclusive.
C if incre is positive, then the index values will be incremented.
C if incre is negative, then the kewords with index = COLMIN
C will be deleted and the index of higher numbered keywords will
C be decremented.
C iunit i Fortran I/O unit number
C colmin i starting column number to be incremented
C colmax i maximum column number to be increment
C incre i amount by which the index value should be shifted
C status i returned error status (0=ok)
integer iunit,colmin,colmax,incre,status
C COMMON BLOCK DEFINITIONS:--------------------------------------------
integer nf,nb,ne
parameter (nb = 20)
parameter (nf = 3000)
parameter (ne = 200)
integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt
integer nxtfld
logical wrmode
common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb),
& wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld
integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount
integer theap,nxheap
double precision tscale,tzero
common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb),
& tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb)
& ,theap(nb),nxheap(nb)
C END OF COMMON BLOCK DEFINITIONS-----------------------------------
integer ibuff,typhdu,tflds,nkeys,nmore,nrec,ival,tstat,i1
character rec*80,newkey*8,q*4
C define the number of the buffer used for this file
ibuff=bufnum(iunit)
C test that the CHDU is an ASCII table or BINTABLE
typhdu=hdutyp(ibuff)
if (typhdu .ne. 1 .and. typhdu .ne. 2)then
status=235
call ftpmsg('Can only operate on TABLE or '//
& 'BINTABLE extension (FTKSHF)')
return
end if
C test column number limits
tflds=tfield(ibuff)
if (colmin .lt. 1 .or. colmax .lt. 1)then
status=302
return
else if (colmin .gt. colmax .or. colmin .gt. tflds)then
return
end if
C get the number of keywords in the header
call ftghsp(iunit,nkeys,nmore,status)
C go thru header starting with the 9th keyword looking for 'TxxxxNNN'
nrec=9
100 call ftgrec(iunit,nrec,rec,status)
if (rec(1:1) .eq. 'T')then
q=rec(2:5)
i1=6
C search list of 5-character 'official' indexed keywords
if ( q .eq. 'BCOL' .or. q .eq. 'FORM' .or. q .eq. 'TYPE'
& .or. q .eq. 'UNIT' .or. q .eq. 'NULL' .or. q .eq. 'SCAL'
& .or. q .eq. 'ZERO' .or. q .eq. 'DISP')go to 20
C search list of 5-character 'local' indexed keywords
if ( q .eq. 'LMIN' .or. q .eq. 'LMAX' .or. q .eq. 'DMIN'
& .or. q .eq. 'DMAX' .or. q .eq. 'CTYP' .or. q .eq. 'CRPX'
& .or. q .eq. 'CRVL' .or. q .eq. 'CDLT' .or. q .eq. 'CROT'
& .or. q .eq. 'CUNI')go to 20
q=rec(1:4)
i1=5
C search list of 4-character 'official' indexed keywords
if (q .eq. 'TDIM')go to 20
C no match so go on to next keyword
go to 90
20 continue
C try reading the index number suffix
tstat=0
call ftc2ii(rec(i1:8),ival,tstat)
if (tstat .eq. 0 .and. ival .ge. colmin .and.
& ival .le. colmax)then
if (incre .le. 0 .and. ival .eq. colmin)then
C delete keyword related to this column
call ftdrec(iunit,nrec,status)
nkeys=nkeys-1
nrec=nrec-1
else
ival=ival+incre
i1=i1-1
call ftkeyn(rec(1:i1),ival,newkey,status)
rec(1:8)=newkey
C modify the index number of this keyword
call ftmrec(iunit,nrec,rec,status)
end if
end if
end if
90 nrec=nrec+1
if (nrec .le. nkeys)go to 100
end
|
