C-------------------------------------------------------------------------- subroutine ftpcbo(ounit,gsize,ngroup,offset,cbuff,status) C "Put Character BuFfer with Offsets" C copy input buffer of characters to the output character buffer. C ounit i Fortran output unit number C gsize i size of each group of bytes C ngroup i number of groups to write C offset i size of gap between groups C cbuff c input character string C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Dec 1996 integer ounit,gsize,ngroup,offset,status character cbuff*(*) C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nb,ne,pb parameter (nb = 20) parameter (ne = 512) parameter (pb = 20) 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 buflun,currnt,reclen,bytnum,maxrec common/ftlbuf/buflun(nb),currnt(nb),reclen(nb), & bytnum(nb),maxrec(nb) integer maxbuf,logbuf,recnum,pindex logical modify common/ftpbuf/maxbuf,logbuf(pb),recnum(pb),modify(pb), & pindex(pb) C have to use separate character arrays because of compiler limitations character*2880 b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14, & b15,b16,b17,b18,b19,b20 common /ftbuff/b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11,b12,b13,b14, & b15,b16,b17,b18,b19,b20 C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer lbuff,pbuff,buflen,lastb,nleft,in1,nbyt integer i,bytno,record,oldrec,incre if (status .gt. 0)return lbuff=bufnum(ounit) if (.not. wrmode(lbuff))then C don't have write access to this file status=112 return end if buflen=reclen(lbuff) pbuff =currnt(lbuff) oldrec=recnum(pbuff) C lastb = position of last byte read or written in FITS buffer lastb =bytnum(lbuff) bytno =(oldrec-1) * buflen + lastb C in1 = position of first byte remaining in the input buffer in1 =1 incre =gsize+offset nbyt = 0 do 500 i = 1,ngroup C nleft = number of bytes left in the input buffer nleft=gsize C nbyt = number of bytes to transfer from input to output nbyt=min(nleft,buflen-lastb) if (nbyt .eq. 0)go to 300 200 continue C append the input buffer to the output physical buffer go to (1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18, & 19,20)pbuff C if got here, then pbuff is out of range status=101 return 1 b1(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 2 b2(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 3 b3(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 4 b4(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 5 b5(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 6 b6(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 7 b7(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 8 b8(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 9 b9(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 10 b10(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 11 b11(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 12 b12(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 13 b13(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 14 b14(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 15 b15(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 16 b16(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 17 b17(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 18 b18(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 19 b19(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) go to 100 20 b20(lastb+1:lastb+nbyt)=cbuff(in1:in1+nbyt-1) 100 in1=in1+nbyt nleft=nleft-nbyt C process more bytes, if any 300 continue if (nleft .gt. 0)then C entire group did not fit in the buffer C load the next file record into a physical buffer oldrec=oldrec+1 modify(pbuff)=.true. call ftldrc(ounit,oldrec,.true.,status) if (status .gt. 0)return pbuff=currnt(lbuff) lastb=0 nbyt=nleft go to 200 end if if (i .ne. ngroup)then C move to the position of the next group bytno=bytno+incre record=bytno/buflen+1 lastb=mod(bytno,buflen) if (record .ne. oldrec)then C not the current record, so load the new record; modify(pbuff)=.true. call ftldrc(ounit,record,.true.,status) if (status .gt. 0)return oldrec=record pbuff=currnt(lbuff) end if end if 500 continue modify(pbuff)=.true. bytnum(lbuff)=lastb+nbyt end