C-------------------------------------------------------------------------- subroutine ftgcbo(iunit,gsize,ngroup,offset,array,status) C "Get Character BuFfer with Offsets" C read characters from the character buffer. C iunit i Fortran output unit number C gsize i size of each group of bytes C ngroup i number of groups to read C offset i size of gap between groups C array c output character string C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, Dec 1996 integer iunit,gsize,ngroup,offset,status character*(*) array 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(iunit) buflen=reclen(lbuff) pbuff =currnt(lbuff) oldrec=recnum(pbuff) C lastb = position of last byte read from input buffer lastb =bytnum(lbuff) bytno =(oldrec-1) * buflen + lastb C in1 = position of first byte remaining in the input buffer in1 =1 nbyt =0 incre =gsize+offset 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 get characters from the physical buffer to the output string 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 array(in1:in1+nbyt-1)=b1(lastb+1:lastb+nbyt) go to 100 2 array(in1:in1+nbyt-1)=b2(lastb+1:lastb+nbyt) go to 100 3 array(in1:in1+nbyt-1)=b3(lastb+1:lastb+nbyt) go to 100 4 array(in1:in1+nbyt-1)=b4(lastb+1:lastb+nbyt) go to 100 5 array(in1:in1+nbyt-1)=b5(lastb+1:lastb+nbyt) go to 100 6 array(in1:in1+nbyt-1)=b6(lastb+1:lastb+nbyt) go to 100 7 array(in1:in1+nbyt-1)=b7(lastb+1:lastb+nbyt) go to 100 8 array(in1:in1+nbyt-1)=b8(lastb+1:lastb+nbyt) go to 100 9 array(in1:in1+nbyt-1)=b9(lastb+1:lastb+nbyt) go to 100 10 array(in1:in1+nbyt-1)=b10(lastb+1:lastb+nbyt) go to 100 11 array(in1:in1+nbyt-1)=b11(lastb+1:lastb+nbyt) go to 100 12 array(in1:in1+nbyt-1)=b12(lastb+1:lastb+nbyt) go to 100 13 array(in1:in1+nbyt-1)=b13(lastb+1:lastb+nbyt) go to 100 14 array(in1:in1+nbyt-1)=b14(lastb+1:lastb+nbyt) go to 100 15 array(in1:in1+nbyt-1)=b15(lastb+1:lastb+nbyt) go to 100 16 array(in1:in1+nbyt-1)=b16(lastb+1:lastb+nbyt) go to 100 17 array(in1:in1+nbyt-1)=b17(lastb+1:lastb+nbyt) go to 100 18 array(in1:in1+nbyt-1)=b18(lastb+1:lastb+nbyt) go to 100 19 array(in1:in1+nbyt-1)=b19(lastb+1:lastb+nbyt) go to 100 20 array(in1:in1+nbyt-1)=b20(lastb+1:lastb+nbyt) 100 in1=in1+nbyt nleft=nleft-nbyt C process more bytes, if any 300 continue if (nleft .gt. 0)then C load the next file record into a physical buffer oldrec=oldrec+1 call ftldrc(iunit,oldrec,.false.,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; call ftldrc(iunit,record,.false.,status) if (status .gt. 0)return oldrec=record pbuff=currnt(lbuff) end if end if 500 continue bytnum(lbuff)=lastb+nbyt end