C---------------------------------------------------------------------- subroutine ftpcli(ounit,colnum,frow,felem,nelem,array,status) C write an array of integer*2 data values to the specified column of C the table. C ounit i fortran unit number C colnum i number of the column to write to C frow i first row to write C felem i first element within the row to write C nelem i number of elements to write C array i*2 array of data values to be written C status i output error status C C written by Wm Pence, HEASARC/GSFC, June 1991 integer ounit,colnum,frow,felem,nelem,status integer*2 array(*) integer ibuff,twidth,tcode,maxpix,startp integer estart,incre,repeat,lenrow,hdtype integer bstart,i1,ntodo,itodo,rstart,ival double precision scale,zero,dval real rval logical tofits,lval,trans integer*2 i2val character sval*30,sform*13,snull*8,i1val*1,messge*80 double precision i4max,i4min parameter (i4max=2.14748364749D+09) parameter (i4min=-2.14748364849D+09) integer maxi4,mini4 parameter (maxi4=2147483647) character*1 chbuff(32000) common/ftheap/chbuff integer*2 buffer(16000) common/fttemp/buffer integer compid common/ftcpid/compid C work around for bug in the DEC Alpha VMS compiler mini4=-2147483647 - 1 if (status .gt. 0)return call ftgcpr(ounit,colnum,frow,felem,nelem,1, & ibuff,scale,zero,sform,twidth,tcode,maxpix,startp, & estart,incre,repeat,lenrow,hdtype,ival,snull,status) if (status .gt. 0 .or. nelem .eq. 0)return i1=1 ntodo=nelem rstart=0 C the data are being scaled from internal format to FITS: tofits=.true. C see if we can write the raw input bytes, or whether we have to C copy data to temporary array prior to byteswapping or scaling if ((compid .eq. 0) .and. & abs(tcode) .eq. 21 .and. & scale .eq. 1.D00 .and. zero .eq. 0.D00)then trans=.false. else trans=.true. end if C process as many contiguous pixels as possible, up to buffer size 20 itodo=min(ntodo,repeat-estart,maxpix) C move the i/o pointer to the start of the sequence of pixels bstart=startp + rstart*lenrow + estart*incre call ftmbyt(ounit,bstart,.true.,status) C copy data to buffer, doing scaling and datatype conversion, if required if (tcode .eq. 21)then C column data type is I (I*2) if (trans)then C convert the input data into a temporary buffer call fti2i2(array(i1),itodo,scale,zero,tofits, & ival,i2val,i2val,lval,lval,buffer,status) C do any machine dependent conversion and write the I*2 data call ftpi2b(ounit,itodo,incre,buffer,status) else C directly write the input array call ftpi2b(ounit,itodo,incre,array(i1),status) end if else if (tcode .eq. 41)then C column data type is J (I*4) call fti2i4(array(i1),itodo,scale,zero,tofits, & ival,i2val,ival,lval,lval,buffer,status) C do any machine dependent data conversion and write the I*4 data call ftpi4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 42)then C column data type is E (R*4) call fti2r4(array(i1),itodo,scale,zero,tofits, & ival,i2val,rval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*4 data call ftpr4b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 82)then C column data type is D (R*8) call fti2r8(array(i1),itodo,scale,zero,tofits, & ival,i2val,dval,lval,lval,buffer,status) C do any machine dependent data conversion and write the R*8 data call ftpr8b(ounit,itodo,incre,buffer,status) else if (tcode .eq. 11)then C column data type is B (byte) call fti2i1(array(i1),itodo,scale,zero,tofits, & ival,i2val,i1val,lval,lval,chbuff,status) C do any machine dependent data conversion and write the byte data call ftpi1b(ounit,itodo,incre,chbuff,status) else C this is an ASCII table column dval=(array(i1)-zero)/scale if (sform(5:5) .eq. 'I')then C column data type is integer C trap any values that overflow the I*4 range if (dval .lt. i4max .and. dval .gt. i4min)then ival=nint(dval) else if (dval .ge. i4max)then status=-11 ival=maxi4 else status=-11 ival=mini4 end if C create the formated character string write(sval,sform,err=900)ival else C create the formated character string write(sval,sform,err=900)dval end if C write the character string to the FITS file call ftpcbf(ounit,twidth,sval,status) end if if (status .gt. 0)then write(messge,1001)i1,i1+itodo-1 1001 format('Error writing elements',i9,' thru',i9, & ' of input data array (FTPCLI).') call ftpmsg(messge) return end if C find number of pixels left to do, and quit if none left ntodo=ntodo-itodo if (ntodo .gt. 0)then C increment the pointers i1=i1+itodo estart=estart+itodo if (estart .eq. repeat)then estart=0 rstart=rstart+1 end if go to 20 end if C check for any overflows if (status .eq. -11)then status=412 messge='Numerical overflow during type '// & 'conversion while writing FITS data.' call ftpmsg(messge) end if return 900 continue C error writing formatted data value to ASCII table write(messge,1002)colnum,rstart+1 1002 format('Error writing column',i4,', row',i9, & ' of the ASCII Table.') call ftpmsg(messge) call ftpmsg('Tried to write value with format '//sform) status=313 end