diff options
Diffstat (limited to 'pkg/tbtables/cfitsio/iter_b.f')
| -rw-r--r-- | pkg/tbtables/cfitsio/iter_b.f | 193 |
1 files changed, 193 insertions, 0 deletions
diff --git a/pkg/tbtables/cfitsio/iter_b.f b/pkg/tbtables/cfitsio/iter_b.f new file mode 100644 index 00000000..7a2a6e7d --- /dev/null +++ b/pkg/tbtables/cfitsio/iter_b.f @@ -0,0 +1,193 @@ + program f77iterate_b + +C external work function is passed to the iterator + external str_iter + + integer ncols + parameter (ncols=2) + integer units(ncols), colnum(ncols), datatype(ncols) + integer iotype(ncols), offset, rows_per_loop, status + character*70 colname(ncols) + + integer iunit, blocksize + character*80 fname + +C include f77.inc ------------------------------------- +C Codes for FITS extension types + integer IMAGE_HDU, ASCII_TBL, BINARY_TBL + parameter ( + & IMAGE_HDU = 0, + & ASCII_TBL = 1, + & BINARY_TBL = 2 ) + +C Codes for FITS table data types + + integer TBIT,TBYTE,TLOGICAL,TSTRING,TSHORT,TINT + integer TFLOAT,TDOUBLE,TCOMPLEX,TDBLCOMPLEX + parameter ( + & TBIT = 1, + & TBYTE = 11, + & TLOGICAL = 14, + & TSTRING = 16, + & TSHORT = 21, + & TINT = 31, + & TFLOAT = 42, + & TDOUBLE = 82, + & TCOMPLEX = 83, + & TDBLCOMPLEX = 163 ) + +C Codes for iterator column types + + integer InputCol, InputOutputCol, OutputCol + parameter ( + & InputCol = 0, + & InputOutputCol = 1, + & OutputCol = 2 ) +C End of f77.inc ------------------------------------- + + status = 0 + + fname = 'iter_b.fit' + iunit = 15 + +C both columns are in the same FITS file + units(1) = iunit + units(2) = iunit + +C open the file and move to the correct extension + call ftopen(iunit,fname,1,blocksize,status) + call ftmnhd(iunit, BINARY_TBL, 'iter_test', 0, status) + +C define the desired columns by name + colname(1) = 'Avalue' + colname(2) = 'Lvalue' + +C leave column numbers undefined + colnum(1) = 0 + colnum(2) = 0 + +C define the desired datatype for each column: TSTRING & TLOGICAL + datatype(1) = TSTRING + datatype(2) = TLOGICAL + +C define whether columns are input, input/output, or output only +C Both in/out + iotype(1) = InputOutputCol + iotype(2) = InputOutputCol + +C use default optimum number of rows and process all the rows + rows_per_loop = 0 + offset = 0 + +C apply the function to each row of the table + print *,'Calling iterator function...', status + + call ftiter( ncols, units, colnum, colname, datatype, iotype, + & offset, rows_per_loop, str_iter, 0, status ) + + call ftclos(iunit, status) + +C print out error messages if problem + if (status.ne.0) call ftrprt('STDERR', status) + stop + end + +C-------------------------------------------------------------------------- +C +C Sample iterator function. +C +C-------------------------------------------------------------------------- + subroutine str_iter(totalrows, offset, firstrow, nrows, ncols, + & units, colnum, datatype, iotype, repeat, status, + & userData, stringCol, logicalCol ) + + integer totalrows,offset,firstrow,nrows,ncols,status + integer units(*),colnum(*),datatype(*),iotype(*),repeat(*) + integer userData + character*(*) stringCol(*) + logical logicalCol(*) + + integer ii + +C include f77.inc ------------------------------------- +C Codes for FITS extension types + integer IMAGE_HDU, ASCII_TBL, BINARY_TBL + parameter ( + & IMAGE_HDU = 0, + & ASCII_TBL = 1, + & BINARY_TBL = 2 ) + +C Codes for FITS table data types + + integer TBIT,TBYTE,TLOGICAL,TSTRING,TSHORT,TINT + integer TFLOAT,TDOUBLE,TCOMPLEX,TDBLCOMPLEX + parameter ( + & TBIT = 1, + & TBYTE = 11, + & TLOGICAL = 14, + & TSTRING = 16, + & TSHORT = 21, + & TINT = 31, + & TFLOAT = 42, + & TDOUBLE = 82, + & TCOMPLEX = 83, + & TDBLCOMPLEX = 163 ) + +C Codes for iterator column types + + integer InputCol, InputOutputCol, OutputCol + parameter ( + & InputCol = 0, + & InputOutputCol = 1, + & OutputCol = 2 ) +C End of f77.inc ------------------------------------- + + if (status .ne. 0) return + +C -------------------------------------------------------- +C Initialization procedures: execute on the first call +C -------------------------------------------------------- + if (firstrow .eq. 1) then + if (ncols .ne. 2) then + status = -1 + return + endif + + if (datatype(1).ne.TSTRING .or. datatype(2).ne.TLOGICAL) then + status = -2 + return + endif + + print *,'Total rows, No. rows = ',totalrows, nrows + + endif + +C ------------------------------------------- +C Main loop: process all the rows of data +C ------------------------------------------- + +C NOTE: 1st element of array is the null pixel value! +C Loop over elements 2 to nrows+1, not 1 to nrows. + + do 10 ii=2,nrows+1 + print *, stringCol(ii), logicalCol(ii) + if( logicalCol(ii) ) then + logicalCol(ii) = .false. + stringCol(ii) = 'changed to false' + else + logicalCol(ii) = .true. + stringCol(ii) = 'changed to true' + endif + 10 continue + +C ------------------------------------------------------- +C Clean up procedures: after processing all the rows +C ------------------------------------------------------- + + if (firstrow + nrows - 1 .eq. totalrows) then +C no action required in this case + endif + + return + end + |