C-------------------------------------------------------------------------- subroutine ftgcbf(iunit,nchar,array,status) C "Get Character BuFfer" C read NCHAR characters from the character buffer. C iunit i Fortran unit number for reading from disk C nchar i number of characters to read C array c output 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 iunit,nchar,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 nleft,nbyt,lastb,in1,lbuff,pbuff,buflen,nrec,ios,i if (status .gt. 0)return if (nchar .lt. 0)then C error: negative number of bytes to read status=306 return end if lbuff=bufnum(iunit) buflen=reclen(lbuff) 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 remaining bytes that can be read from buffer 200 pbuff=currnt(lbuff) lastb=bytnum(lbuff) nbyt=min(nleft,buflen-lastb) C get characters from the physical buffer to the output string if (nbyt .gt. 0)then 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 C The SUN F90 compiler gives a segmentation fault on the following C statement when executing testprog, while reading a complex (C) column C when using the Linux F90 routines (fitsf90_nag.f). 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 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 150 continue if (nleft .gt. buflen)then C read whole blocks directly from the FITS file by-passing buffers C test if desired record exists before trying to read it if (nrec + nleft/buflen - 1 .gt. maxrec(lbuff)) then C record doesn't exist, so return EOF error status=107 return end if C check if record is already loaded in one of the physical buffers C must read it from buffer since it may have been modified do 120 i=1,maxbuf if (logbuf(i) .eq. lbuff .and. recnum(i) .eq. nrec)then C found the desired record; don't have to read it go to 170 end if 120 continue C record not already loaded in buffer, so read it from disk read(iunit,rec=nrec,iostat=ios)array(in1:in1+buflen-1) if (ios .ne. 0)then C assume that this error indicates an end of file condition status=107 return end if bytnum(lbuff)=bytnum(lbuff)+buflen in1=in1+buflen nleft=nleft-buflen nrec=nrec+1 go to 150 end if C load the next file record into a physical buffer 170 call ftldrc(iunit,nrec,.false.,status) if (status .gt. 0)return go to 200 end if end