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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
|
C--------------------------------------------------------------------------
subroutine ftrwup(iunit,frow,lrow,nshift,status)
C shift rows in a table up by NROWS rows, overwriting the rows above
C iunit i Fortran I/O unit number
C frow i first row to be moved up
C lrow i last row to be moved up (last row of the table)
C nshift i how far to shift the rows (number of rows)
C status i returned error status (0=ok)
integer iunit,frow,lrow,nshift,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)
character*1 buff(5760)
common/ftheap/buff
C END OF COMMON BLOCK DEFINITIONS-----------------------------------
integer ibuff,kshift,nchar,fchar,i,j
integer lstptr,inptr,outptr,nseg
character cfill*1
if (status .gt. 0)return
C define the number of the buffer used for this file
ibuff=bufnum(iunit)
C select appropriate fill value
if (hdutyp(ibuff) .eq. 1)then
C fill header or ASCII table with space
cfill=char(32)
else
C fill image or bintable data area with Null (0)
cfill=char(0)
end if
C **********************************************************************
C CASE #1: One or more rows of the table will fit in the work buffer,
C **********************************************************************
if (rowlen(ibuff) .le. 5760)then
C how many rows can we move at one time?
kshift=5760/rowlen(ibuff)
fchar=1
C check if we just need to clear the last NSHIFT rows of the table
if (frow .eq. lrow+1)go to 25
C initialize pointers
inptr=frow
lstptr=inptr+kshift
20 if (lstptr .gt. lrow)lstptr=lrow
nchar=(lstptr-inptr+1)*rowlen(ibuff)
outptr=inptr-nshift
C read the row(s) to be shifted
call ftgtbs(iunit,inptr,fchar,nchar,buff,status)
C write the row(s) to the new location
call ftptbs(iunit,outptr,fchar,nchar,buff,status)
C If there are more rows, update pointers and repeat
if (lstptr .lt. lrow)then
inptr =inptr +kshift
lstptr=lstptr+kshift
go to 20
end if
C initialize the buffer with the fill value
25 continue
do 30 i=1,5760
buff(i)=cfill
30 continue
C fill the empty rows at the bottom of the table with blanks or nulls
nchar=rowlen(ibuff)
do 35 i=1,nshift
outptr=lrow-nshift+i
call ftptbs(iunit,outptr,fchar,nchar,buff,status)
35 continue
return
C **********************************************************************
C CASE #2: Cannot fit a whole row into the work buffer, so have
C to move each row in pieces.
C **********************************************************************
else
nseg=(rowlen(ibuff)+5759)/5760
nchar=5760
do 60 j=1,nseg
fchar=(j-1)*5760+1
if (j .eq. nseg)nchar=rowlen(ibuff)-(nseg-1)*5760
C check if we just need to clear the last NSHIFT rows of the table
if (frow .eq. lrow+1)go to 45
do 40 i=frow,lrow
C read the row to be shifted
call ftgtbs(iunit,i,fchar,nchar,buff,status)
C write the row(s) to the new location
call ftptbs(iunit,i-nshift,fchar,nchar,buff,status)
40 continue
C initialize the buffer with the fill value
45 continue
do 50 i=1,5760
buff(i)=cfill
50 continue
C fill the empty rows with blanks or nulls
do 55 i=1,nshift
outptr=lrow-nshift+i
call ftptbs(iunit,outptr,fchar,nchar,buff,status)
55 continue
60 continue
end if
end
|
