C-------------------------------------------------------------------------- subroutine ftpcbf(ounit,nchar,cbuff,status) C "Put Character BuFfer" C copy input buffer of characters to the output character buffer. C ounit i Fortran output unit number C nchar i number of characters in the string C cbuff c input character string C status i output error status (0 = ok) C C written by Wm Pence, HEASARC/GSFC, June 1991 C modified Feb 1995 integer ounit,nchar,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,nrec if (status .gt. 0)return lbuff=bufnum(ounit) buflen=reclen(lbuff) if (nchar .lt. 0)then C error: negative number of bytes to write status=306 return else if (.not. wrmode(lbuff))then C don't have write access to this file status=112 return end if C lastb = position of last byte read from input buffer C nleft = number of bytes left in the input buffer C in1 = position of first byte remaining in the input buffer C nbyt = number of bytes to transfer from input to output nleft=nchar in1=1 C find the number of bytes that will fit in output buffer 200 pbuff=currnt(lbuff) lastb=bytnum(lbuff) nbyt=min(nleft,buflen-lastb) if (nbyt .gt. 0)then 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 modify(pbuff)=.true. bytnum(lbuff)=bytnum(lbuff)+nbyt in1=in1+nbyt nleft=nleft-nbyt end if C process more bytes, if any if (nleft .gt. 0)then nrec=recnum(pbuff)+1 if (nleft .gt. buflen)then C first, flush any current buffers to disk call ftflsh(lbuff,status) C write whole blocks directly to the FITS file by-passing buffers 150 write(ounit,rec=nrec,err=900)cbuff(in1:in1+buflen-1) in1=in1+buflen nleft=nleft-buflen bytnum(lbuff)=bytnum(lbuff)+buflen nrec=nrec+1 if (nleft .gt. buflen)go to 150 C Save maximum record written, for comparison in ftread maxrec(lbuff) = max(maxrec(lbuff), nrec-1) end if C load the next file record into a physical buffer call ftldrc(ounit,nrec,.true.,status) if (status .gt. 0)return go to 200 end if return C come here if there was a disk write error of some sort 900 status=106 end