From fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 Mon Sep 17 00:00:00 2001 From: Joseph Hunkeler Date: Wed, 8 Jul 2015 20:46:52 -0400 Subject: Initial commit --- pkg/tbtables/fitsio/fti1i1.f | 129 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 129 insertions(+) create mode 100644 pkg/tbtables/fitsio/fti1i1.f (limited to 'pkg/tbtables/fitsio/fti1i1.f') diff --git a/pkg/tbtables/fitsio/fti1i1.f b/pkg/tbtables/fitsio/fti1i1.f new file mode 100644 index 00000000..ba2f70a5 --- /dev/null +++ b/pkg/tbtables/fitsio/fti1i1.f @@ -0,0 +1,129 @@ +C---------------------------------------------------------------------- + subroutine fti1i1(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*1 values to output i*1 values, doing optional +C scaling and checking for null values + +C input c*1 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval c*1 value in the input array that is used to indicated nulls +C setval c*1 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output c*1 returned array of values +C status i output error status (0 = ok) + + character*1 input(*),chkval + character*1 output(*),setval + integer n,i,chktyp,status,itemp + double precision scale,zero,dval + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=(itemp-zero)/scale +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +60 continue + end if + end if + end if + end -- cgit