Документ взят из кэша поисковой машины. Адрес оригинального документа : http://www.atnf.csiro.au/computing/software/gipsy/tsk/insert.shl Дата изменения: Thu Sep 7 16:22:35 1995 Дата индексирования: Fri Jan 16 01:12:34 2009 Кодировка:

E PROGRAM INSERT (copyright notice)
C insert.shl
C COPYRIGHT (c) 1991, 1995
C Kapteyn Astronomical Institute - University of Groningen
C P.O. box 800, 9700 AV Groningen, The Netherlands
C
E PROGRAM INSERT (insert.dc1)
C#> insert.dc1
C
CProgram: INSERT
C
CPurpose: Program to insert (multiple) (parts of) a set into another
C existing set.
C
CCategory: TRANSFER, MANIPULATION
C
CFile: insert.shl
C
CAuthor: K.G. Begeman
C
CKeywords:
C
C INSET= Set (and subset(s)) where to copy data from. Maximum
C number of input and output subsets is 2048.
C
C OUTSET= Set and subset(s) where to insert the data. The set and
C subsets must exist.
C
C** REPEAT= Repeat keywords INBOX= and OUTBOX= to insert multiple parts
C of input set into output set [N].
C
C INBOX= Part of subsets to be inserted [REPEAT=N,whole subset;
C REPEAT=Y,quit].
C
C OUTBOX= Part of subsets where to insert [REPEAT=N,no default;
C REPEAT=Y,INBOX]. The size of the OUTBOX must equal the
C size of INBOX.
C
CUpdates: Sep 25, 1991: KGB, Document created.
C Sep 6, 1995: KGB, Keyword REPEAT= implemented.
C
C#<
E PROGRAM INSERT (code)
program insert
C
C Declaration of parameters:
C
character*(*) ident
N Change version number on this line
parameter (ident = ' INSERT Version 1.1 Sep , 1995 ')
integer maxaxes
N Maximum number of axes in a set
parameter (maxaxes = 10)
integer maxsubs
N Maximum number of subsets
parameter (maxsubs = 2048)
integer maxbuf
N Size of data array
parameter (maxbuf = 4096)
C
C Declarations for input set
C
N Name of input set
character*80 set1
N Permutation of axes for input set
integer axperm1(maxaxes)
N Ax size array
integer axsize1(maxaxes)
N Coordinate words for gdsi_read
integer cwlo1, cwhi1
N Frame of input subsets
integer blo1(maxaxes), bhi1(maxaxes)
N Coordinate words of input subsets
integer subset1(maxsubs)
N Transfer id input set
integer tid1
C
C Declarations for output set
C
N Name of output set
character*80 set2
N Permutation of axes for output set
integer axperm2(maxaxes)
N Ax size array
integer axsize2(maxaxes)
N Coordinate words for gdsi_write
integer cwlo2, cwhi2
N Frame of output subsets
integer blo2(maxaxes), bhi2(maxaxes)
N Coordinate words of output subsets
integer subset2(maxsubs)
N Transfer id output set
integer tid2
C
C Declaration of local variables:
C
N Dummy string
character string*512
N Dummy integer
integer dummy
N Mode for gdsbox
integer mode
N Counter
integer n
N Number of pixels to read
integer nr
N Subset counter
integer ns
N Number of subsets to copy
integer nsubs
N Dimension of subsets
integer subdim
N Logical
logical loop
N Arrays for input data
real data(maxbuf)
C
C Declaration of functions:
C
N Returns coordinate word
integer gdsc_fill
N Returns number of input subsets
integer gdsinp
N Gets booleans
integer userlog
N Gets text
integer usertext
C
C Data statements:
C
N Repeat mode
data loop / .false. /
N Subset dimension
data subdim / 0 /
C
C Executable code:
C
N Get in touch with HERMES
call init
N Tell user who we are
call anyout( 8, ident )
N Get number of input subsets
nsubs = gdsinp( set1,
# subset1,
# maxsubs,
# 0,
# 'INSET=',
# ' ',
# 11,
# axperm1,
# axsize1,
# maxaxes,
# 1,
# subdim )
N get output set
nsubs = gdsinp( set2,
# subset2,
# nsubs,
# 4,
# 'OUTSET=',
# ' ',
# 11,
# axperm2,
# axsize2,
# maxaxes,
# 1,
# subdim )
dummy = userlog( loop, 1, 2, 'REPEAT=',
# 'Repeat operation [N]' )
C Start of loop
repeat
if ( loop )
then
if ( usertext( string, 1, 'INBOX=',
# 'Enter box to insert from [quit]' )
# .EQ. 0 )
then
xrepeat
cif
cif
perform doit
until ( .not. loop )
call status( 'Updating minimum and maximum' )
call uminmax( set2, subset2, nsubs, 1 )
N Tell HERMES we're done
call finis
C
C End of program
C
stop
E Procedure doit
proc doit

call gdsbox( blo1,
# bhi1,
# set1,
# subset1,
# 1,
# 'INBOX=',
# ' ',
# 11,
# 0 )
if ( loop )
then
call cancel( 'INBOX=' )
for n = 1, subdim
bhi2(n) = bhi1(n)
blo2(n) = blo1(n)
cfor
mode = 6
else
for n = 1, subdim
bhi2(n) = bhi1(n) - blo1(n) + 1
cfor
mode = 12
cif
call gdsbox( blo2,
# bhi2,
# set2,
# subset2,
# 1,
# 'OUTBOX=',
# ' ',
# 11,
# mode )
if ( loop )
then
call cancel( 'OUTBOX=' )
cif
for n = 1, subdim
if ((bhi2(n) - blo2(n) + 1) .ne. (bhi1(n) - blo1(n) + 1))
then
call error( 4, 'Unequal box sizes' )
cif
cfor
N Loop through the subsets
for ns = 1, nsubs
N Show user what we are working on
call showsub2( set1,
# subset1(ns),
# axperm1,
# set2,
# subset2(ns),
# axperm2 )
N Get lower coordinate word of input frame
cwlo1 = gdsc_fill( set1, subset1(ns), blo1 )
N Get upper coordinate word of input frame
cwhi1 = gdsc_fill( set1, subset1(ns), bhi1 )
N Get lower coordinate word of output frame
cwlo2 = gdsc_fill( set2, subset2(ns), blo2 )
N Get upper coordinate word of output frame
cwhi2 = gdsc_fill( set2, subset2(ns), bhi2 )
N Reset transfer id for input data
tid1 = 0
N Reset transfer id for output data
tid2 = 0
repeat
call gdsi_read( set1,
# cwlo1,
# cwhi1,
# data,
# maxbuf,
# nr,
# tid1 )
call gdsi_write( set2,
# cwlo2,
# cwhi2,
# data ,
# nr,
# nr,
# tid2 )
until (tid1 .eq. 0 .and. tid2 .eq. 0)
cfor

cproc
E The End
end