C---------------------------------------------------------------------- subroutine ftgcpr(iunit,colnum,frow,felem,nelem,rwmode, & ibuff,scale,zero,tform,twidth,tcode,maxelm,startp, & elnum,incre,repeat,lenrow,hdtype,inull,snull,status) C Get Column PaRameters, and test starting row and element numbers for C validity. C iunit I - fortran unit number C colnum I - column number (1 = 1st column of table) C frow I - first row (1 = 1st row of table) C felem I - first element within vector (1 = 1st) C nelem I - number of elements to read or write C rwmode I - = 1 if writing data, = 0 if reading data C ibuff O - buffer associated with this file C scale O - FITS scaling factor (TSCALn keyword value) C zero O - FITS scaling zero pt (TZEROn keyword value) C tform O - ASCII column format: value of TFORMn keyword C twidth O - width of ASCII column (characters) C tcode O - column datatype code: I*4=41, R*4=42, etc C maxelm O - max number of elements that fit in buffer C startp O - offset in file to starting row & column C elnum O - starting element number ( 0 = 1st element) C incre O - byte offset between elements within a row C repeat O - number of elements in a row (vector column) C lenrow O - length of a row, in bytes C hdtype O - HDU type: 0, 1, 2 = primary, table, bintable C inull O - null value for integer columns C snull O - null value for ASCII table columns C status IO - error status C written by Wm Pence, HEASARC/GSFC, November 1996 integer iunit,colnum,frow,felem,nelem integer rwmode,ibuff,twidth,tcode,maxelm,startp integer elnum,incre,repeat,lenrow,hdtype,inull integer status character*(*) snull, tform double precision scale,zero C COMMON BLOCK DEFINITIONS:-------------------------------------------- integer nf,nb,ne parameter (nb = 20) parameter (nf = 3000) parameter (ne = 512) 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,heapsz integer theap double precision tscale,tzero common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),heapsz(nb) & ,theap(nb) character cnull*16, cform*8 common/ft0003/cnull(nf),cform(nf) integer compid common/ftcpid/compid C END OF COMMON BLOCK DEFINITIONS----------------------------------- integer datast, xtbcol,acode character*80 messge integer bufdim parameter (bufdim = 32000) ibuff=bufnum(iunit) C if HDU structure is not defined then scan the header keywords if (dtstrt(ibuff) .lt. 0)call ftrdef(iunit,status) C Do sanity check of input parameters if (frow .lt. 1)then write(messge,1001)frow 1001 format('Starting row number is out of range: ',i10) call ftpmsg(messge) status = 307 return else if (hdutyp(ibuff) .ne. 1 .and. felem .lt. 1)then write(messge,1002)felem 1002 format('Starting element number is out of range: ',i10) call ftpmsg(messge) status = 308 return else if (nelem .lt. 0)then write(messge,1003)nelem 1003 format('Negative no. of elements to read or write: ',i10) call ftpmsg(messge) status = 306 return else if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then write(messge,1004)colnum 1004 format('Specified column number is out of range: ',i10) call ftpmsg(messge) status = 302 return else if (nelem .eq. 0)then C not reading or writing any pixels, so just return return end if C copy relevant parameters from the common block hdtype = hdutyp(ibuff) lenrow = rowlen(ibuff) datast = dtstrt(ibuff) tcode = tdtype(colnum+tstart(ibuff)) tform ='( )' tform(5:12)=cform(colnum+tstart(ibuff)) acode = abs(tcode) if ((hdtype .eq. 1 .and. tform(5:5) .eq. 'A') .or. & (hdtype .eq. 2 .and. acode .eq. 16) .or. & acode .eq. 14)then C error: illegal table format code status=311 write(messge,1005)colnum,cform(colnum+tstart(ibuff)) 1005 format('Cannot read or write numerical values in column', & i4,' with TFORM = ',a8) call ftpmsg(messge) return end if if (hdtype .eq. 1 .and. rwmode .eq. 1)then if (tform(5:5) .eq. 'E')then tform(2:4)='1P,' else if (tform(5:5) .eq. 'D')then tform(2:5)='1P,E' end if else if (hdtype .eq. 1)then tform(2:4)='BN,' end if snull = cnull(colnum+tstart(ibuff)) scale= tscale(colnum+tstart(ibuff)) zero= tzero(colnum+tstart(ibuff)) inull= tnull(colnum+tstart(ibuff)) xtbcol= tbcol(colnum+tstart(ibuff)) repeat= trept(colnum+tstart(ibuff)) if (tcode .ne. 16)then twidth=max(acode/10,1) else twidth = tnull(colnum+tstart(ibuff)) end if C Special case: interprete 'X' column as 'B' if (acode .eq. 1)then tcode = tcode * 11 repeat = (repeat + 7) / 8 end if C Special case: support the 'rAw' format in BINTABLEs if (hdtype .eq. 2 .and. tcode .eq. 16)then repeat = repeat / twidth end if if (hdtype .eq. 1)then C ASCII tables don't have vector elements elnum = 0 else elnum = felem - 1 end if C interprete complex and double complex as pairs of floats or doubles if (abs(tcode) .gt. 82)then if (tcode .gt. 0)then tcode = (tcode + 1) / 2 else tcode = (tcode - 1) / 2 end if repeat = repeat * 2 twidth = twidth / 2 end if incre= twidth C calculate no. of pixels that fit in buffer if (hdtype .eq. 1)then C in ASCII tables, can only process 1 value at a time maxelm = 1 else maxelm = bufdim / twidth end if C special case for the SUN F90 compiler where integer*2 C variables are stored in 4-byte integers if (compid .eq. -1 .and. abs(tcode) .eq. 21)then maxelm = bufdim / 4 end if C calc starting byte position to 1st element of col C (this does not apply to variable length columns) startp = datast + ((frow - 1) * lenrow) + xtbcol if (hdtype .eq. 0 .and. rwmode .eq. 1)then C When writing primary arrays, set the repeat count greater than the C total number of pixels to be written. This prevents an out-of-range C error message in cases where the final image array size is not C yet known or defined. repeat = elnum + nelem else if (tcode .gt. 0)then C Fixed length table column if (elnum .ge. repeat)then C illegal element number write(messge,1006)felem 1006 format( & 'Starting element number is greater than repeat: ',i10) call ftpmsg(messge) status = 308 else if (repeat .eq. 1 .and. nelem .gt. 1)then C When accessing a scalar column, fool the calling routine into C thinking that this is a vector column with very big elements. C This allows multiple values (up to the maxelem number of elements C that will fit in the buffer) to be read or written with a single C routine call, which increases the efficiency. incre = lenrow repeat = nelem end if else C Variable length Binary Table column tcode = tcode * (-1) if (rwmode .eq. 1)then C return next empty heap address for writing C total no. of elements in the field repeat = nelem + elnum C calculate starting position (for writing new data) in the heap startp = datast + heapsz(ibuff)+theap(ibuff) C write the descriptor into the fixed length part of table call ftpdes(iunit, colnum, frow, repeat, heapsz(ibuff), & status) C increment the address to the next empty heap position heapsz(ibuff) = heapsz(ibuff) + (repeat * incre) else C get the read start position in the heap call ftgdes(iunit, colnum, frow, repeat, startp, status) if (tdtype(colnum+tstart(ibuff)) .eq. -1)then C Special case: interprete 'X' column as 'B' repeat = (repeat + 7) / 8 end if if (elnum .ge. repeat)then C illegal element number write(messge,1006)felem call ftpmsg(messge) status = 308 end if startp=datast + startp + theap(ibuff) end if end if end