diff options
Diffstat (limited to 'pkg/tbtables/fitsio/ftasfm.f')
| -rw-r--r-- | pkg/tbtables/fitsio/ftasfm.f | 143 |
1 files changed, 143 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/ftasfm.f b/pkg/tbtables/fitsio/ftasfm.f new file mode 100644 index 00000000..0961ce28 --- /dev/null +++ b/pkg/tbtables/fitsio/ftasfm.f @@ -0,0 +1,143 @@ +C---------------------------------------------------------------------- + subroutine ftasfm(form,dtype,width,decims,status) + +C 'ASCII Format' +C parse the ASCII table TFORM column format to determine the data +C type, the field width, and number of decimal places (if relevant) +C +C form c TFORM format string +C OUTPUT PARAMETERS: +C dattyp i datatype code +C width i width of the field +C decims i number of decimal places +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, November 1994 + + character*(*) form + integer dtype,width,decims,status + character dattyp*1,cform*16 + integer nc,c1,i,nw + + if (status .gt. 0)return + + cform=form + +C find first non-blank character + nc=len(form) + do 5 i=1,nc + if (form(i:i) .ne. ' ')then + c1=i + go to 10 + end if +5 continue + +C error: TFORM is a blank string + status=261 + call ftpmsg('The TFORM keyword has a blank value.') + return + +10 continue + +C now the chararcter at position c1 should be the data type code + dattyp=form(c1:c1) + +C set the numeric datatype code + if (dattyp .eq. 'I')then + dtype=41 + else if (dattyp .eq. 'E')then + dtype=42 + else if (dattyp .eq. 'F')then + dtype=42 + else if (dattyp .eq. 'D')then + dtype=82 + else if (dattyp .eq. 'A')then + dtype=16 + else +C unknown tform datatype code + status=262 + call ftpmsg('Unknown ASCII table TFORMn keyword '// + & 'datatype: '//cform) + return + end if + +C determine the field width + c1=c1+1 + nw=0 + do 40 i=c1,nc + if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then + nw=nw+1 + else + go to 50 + end if +40 continue +50 continue + if (nw .eq. 0)then +C error, no width specified + go to 990 + else + call ftc2ii(form(c1:c1+nw-1),width,status) + if (status .gt. 0 .or. width .eq. 0)then +C unrecognized characters following the type code + go to 990 + end if + end if + +C determine the number of decimal places (if any) + decims=-1 + c1=c1+nw + if (form(c1:c1) .eq. '.')then + c1=c1+1 + nw=0 + do 60 i=c1,nc + if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then + nw=nw+1 + else + go to 70 + end if +60 continue +70 continue + + if (nw .eq. 0)then +C error, no decimals specified + go to 990 + else + call ftc2ii(form(c1:c1+nw-1),decims,status) + if (status .gt. 0)then +C unrecognized characters + go to 990 + end if + end if + else if (form(c1:c1) .ne. ' ')then + go to 990 + end if + +C consistency checks + if (dattyp .eq. 'A' .or. dattyp .eq. 'I')then + if (decims .eq. -1)then + decims=0 + else + go to 990 + end if + else if (decims .eq. -1)then +C number of decmal places must be specified for D, E, or F fields + go to 990 + else if (decims .ge. width)then +C number of decimals must be less than the width + go to 990 + end if + + if (dattyp .eq. 'I')then +C set datatype to SHORT integer if 4 digits or less + if (width .le. 4)dtype=21 + else if (dattyp .eq. 'F')then +C set datatype to DOUBLE if 8 digits or more + if (width .ge. 8)dtype=82 + end if + + return + +990 continue + status=261 + call ftpmsg('Illegal ASCII table TFORMn keyword: '//cform) + end |