[daip] VBGLU bug
Eric Greisen
egreisen at nrao.edu
Tue Jan 31 10:48:08 EST 2006
Cormac Reynolds writes:
> sorry but it appears that I was premature in declaring VBGLU to work the other
> day. It turns out I made a mistake in the test and in fact joined two copies of
> the same data together (which strangely appeared to work). When I do things
> correctly and try to join the separate IFs together the new VBGLU fails in
> exactly the same way as the old one. Also, contrary to my previous message, the
> first file is 8 IFs of LCP and the second file is 8 IFs (same frequencies) of
> RCP. I'm not sure if this is significant for your algorithm or not. We did get
> VBGLU to work by first averaging the data (and running FXPOL afterwards).
> Apparently this avoided the overflow problem.
>
I am baffled. There is no way that I can fetch 20 Gbytes of data from
Europe it would take days. I am no longer certain what version I sent
you, but I am sure that it was meant to adjust to whatever data were
present. I will attach the version I put back yesterday - could you
run a diff with the one I sent? I suppose I could try to copy your
data although I expect that to fail.
The important places to look are all references to OUTSIZ and the
positioning of the UVDISK call with respect to the
IF ((BUFPTR+(2*ICOP)).GT.OUTSIZ) THEN
block. The correct version has the UVDISK call ahead of that block
since INIO is not known until the UVDISK is called. It is odd that it
dies in referencing the IPT+JLOCT but not in the RCOPY which already
accessed that same address.
Eric Greisen
LOCAL INCLUDE 'VBGLU.INC'
C Local include for VBGLU
INCLUDE 'INCS:ZPBUFSZ.INC'
INCLUDE 'INCS:PUVD.INC'
C The output buffer has to be
C large enough to hold all
C spectral channels for all
C baselines of the VLBA at any
C given time.
HOLLERITH XNAME1(3), XCLAS1(2), XNAME2(3), XCLAS2(2), XNAME3(3),
* XCLAS3(2), XNAME4(3), XCLAS4(2), XNAMOU(3), XCLAOU(2)
REAL XS1, XDISK1, XS2, XDISK2, XS3, XDISK3, XS4, XDISK4,
* XSOUT, XDISO, BUFFI(UVBFSL,4), BUFFO(UVBFSL), TBI(4), TSI(4),
* FINCI(MAXIF,4), FINCO(MAXIF)
DOUBLE PRECISION FOFFI(MAXIF,4), FOFFO(MAXIF), FRQI(MAXIF,4),
* FRQO(MAXIF), UVWSC(4)
INTEGER SEQI(4), SEQOUT, DISKI(4), DISKO, LRECI(4), LRECO,
* CNOI(4), NIFI(4), INCSI(4), INCFI(4), INCIFI(4), INCSO, INCFO,
* INCIFO, NRPRMI(4), NRPRMO, NSTOKS, NCHAN, NIFO, NUMHIS, JBUFSZ,
* ILOCWT, ILOCSC, NVISIN(4), NVISO, ISBI(MAXIF,4), ISBO(MAXIF),
* ORDER(MAXIF), NUMFIL, NUMVIS(4)
LOGICAL GLU3, GLU4
CHARACTER NAMEI(4)*12, CLASI(4)*6, NAMOUT*12, CLAOUT*6,
* HISCRD(10)*64
COMMON /INPARM/ XNAME1, XCLAS1, XS1, XDISK1,
* XNAME2, XCLAS2, XS2, XDISK2,
* XNAME3, XCLAS3, XS3, XDISK3,
* XNAME4, XCLAS4, XS4, XDISK4,
* XNAMOU, XCLAOU, XSOUT, XDISO,
* SEQI, SEQOUT, DISKI, DISKO,
* LRECI, LRECO, CNOI, NIFI,
* INCSI, INCFI, INCIFI, INCSO, INCFO, INCIFO,
* NRPRMI, NRPRMO, NSTOKS, NCHAN, NIFO,
* NUMHIS, ILOCWT, ILOCSC, NVISIN, NVISO, NUMFIL, NUMVIS,
* GLU3, GLU4
COMMON /FDATA/ FOFFI, FOFFO, FRQI, FRQO, UVWSC,
* FINCI, FINCO, TBI, TSI, ISBI, ISBO, ORDER
COMMON /CHARPM/ NAMEI, CLASI, NAMOUT, CLAOUT, HISCRD
COMMON /BUFRS/ BUFFI, BUFFO, JBUFSZ
LOCAL END
LOCAL INCLUDE 'CATS.INC'
INTEGER CATI(256,4)
REAL CATRI(256,4)
HOLLERITH CATHI(256,4)
DOUBLE PRECISION CATDI(128,4)
COMMON /CATMAP/ CATI
EQUIVALENCE (CATI, CATRI, CATHI, CATDI)
LOCAL END
LOCAL INCLUDE 'CONTROL.INC'
INCLUDE 'INCS:PUVD.INC'
INTEGER BUFPTR, MAXBAS, OUTSIZ, ICOP, JLOCT, JLOCB, JLOCIT,
* ANTMAX
C 4X too big
PARAMETER (MAXBAS = 2*MAXANT*(MAXANT+1))
LOGICAL ISCOMP
REAL GOTTIM, FINTIM, RINTIM(MAXBAS), BASIN(MAXBAS),
* INTTIM(MAXBAS)
COMMON /VALS/ GOTTIM, FINTIM, RINTIM, BASIN, INTTIM, OUTSIZ,
* BUFPTR, ICOP, JLOCT, JLOCB, JLOCIT, ISCOMP, ANTMAX
LOCAL END
PROGRAM VBGLU
C-----------------------------------------------------------------------
C! VBGLU Glues together data from multiple passes thru the VLBA corr.
C# Utility UV UV-util VLA VLB SPECTRAL
C-----------------------------------------------------------------------
C; Copyright (C) 1995-1997, 1999-2001, 2006
C; Associated Universities, Inc. Washington DC, USA.
C;
C; This program is free software; you can redistribute it and/or
C; modify it under the terms of the GNU General Public License as
C; published by the Free Software Foundation; either version 2 of
C; the License, or (at your option) any later version.
C;
C; This program is distributed in the hope that it will be useful,
C; but WITHOUT ANY WARRANTY; without even the implied warranty of
C; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
C; GNU General Public License for more details.
C;
C; You should have received a copy of the GNU General Public
C; License along with this program; if not, write to the Free
C; Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
C; MA 02139, USA.
C;
C; Correspondence concerning AIPS should be addressed as follows:
C; Internet email: aipsmail at nrao.edu.
C; Postal address: AIPS Project Office
C; National Radio Astronomy Observatory
C; 520 Edgemont Road
C; Charlottesville, VA 22903-2475 USA
C-----------------------------------------------------------------------
C VBGLU Glues together data that were correlated in multiple passes
C on the VLBA correlator, multiple pass is not used in its historical
C sense of different baselines/pass but in the sense of different
C IFs/pass. This is necessary because the VLBA correlator can only
C deal with 8 IFs at a time, but when MkIII Mode A,B or C are
C correlated the data have to be split up in frequency space.
C
C VBGLU is a generalization of UVGLU. What it does is read the file
C headers and FQ tables and constructs a composite header/FQ table.
C It then uses the first file given by the user as the master file and
C copies that file to output, exapnding it to the appropriate number
C of IFs. It then runs through the (up to 3) other files joining
C together spectra with the same baseline/time. If a record exists
C with no match in the master output file then it will be dropped.
C If there are records in the mastre output file with no match in the
C other input files then the empty IFs will be flagged.
C
C Several assumptions are implicit in this process:
C (1) Data have the same order
C (2) The source/antenna numbers are identical
C (3) There are the same number of spectral channels per IF
C
C Inputs:
C AIPS adverb Prg. name. Description.
C INNAME NAME1 Name of input UV data # 1
C INCLASS CLAS1 Class of input UV data.
C INSEQ SEQ1 Seq. of input UV data.
C INDISK DISK1 Disk number of input UV data
C IN2NAME NAME2 Name of second file to glue
C IN2CLASS CLAS2 Class of second file
C IN2SEQ SEQ2 Seq number of second file.
C IN2DISK DISK2 Vol. no. of second file.
C IN3NAME NAME3 Name of third file to glue
C IN3CLASS CLAS3 Class of third file
C IN3SEQ SEQ3 Seq number of third file.
C IN3DISK DISK3 Vol. no. of third file.
C IN4NAME NAME4 Name of fourth file to glue
C IN4CLASS CLAS4 Class of fourth file
C IN4SEQ SEQ4 Seq number of fourth file.
C IN4DISK DISK4 Vol. no. of fourth file.
C OUTNAME NAMOUT Name of the output uv file.
C OUTCLASS CLAOUT Class of the output uv file.
C OUTSEQ SEQOUT Seq. number of output uv data.
C OUTDISK DISKO Disk number of the output file.
C-----------------------------------------------------------------------
CHARACTER PRGM*6
INTEGER IRET
INCLUDE 'VBGLU.INC'
INCLUDE 'INCS:DFIL.INC'
INCLUDE 'INCS:DMSG.INC'
INCLUDE 'INCS:DDCH.INC'
INCLUDE 'INCS:DHDR.INC'
INCLUDE 'INCS:DUVH.INC'
INCLUDE 'INCS:DCAT.INC'
C
DATA PRGM /'VBGLU '/
C-----------------------------------------------------------------------
C Get input parameters and
C create output file.
CALL VBGLIN (PRGM, IRET)
IF (IRET.NE.0) GO TO 990
C Glue the data together
CALL GLUDAT (IRET)
IF (IRET.NE.0) GO TO 990
CALL VBGHIS
C Then the tables
CALL GLUTAB (IRET)
C Close down files, etc.
990 CALL DIE (IRET, BUFFI(1,1))
C
999 STOP
END
SUBROUTINE VBGLIN (PRGN, JERR)
C-----------------------------------------------------------------------
C VBGLIN gets input parameters for VBGLU and creates an output file
C Inputs:
C PRGN C*6 Program name
C Output:
C JERR I Error code: 0 => ok
C 1 => infiles don't match
C 5 => catalog troubles
C 8 => can't start
C Commons: /INPARM/ all input adverbs in order given by INPUTS
C file
C /MAPHDR/ output file catalog header
C-----------------------------------------------------------------------
INTEGER JERR
CHARACTER PRGN*6
C
CHARACTER STAT*4, BLANK*6, PTYPE*2
INTEGER IROUND, NPARM, IERR, INCX, I, J, ILOCDE, ILOCRA, ILOCIF,
* ILOCF, ILOCS, NNX, NFQ, TIM1(4), TIM2(4), IVER, FREQID, FQLUN,
* IFRQ, INUM, NUMAN(51), ALUN
LOGICAL T, F, WEQ1, WEQ2
INCLUDE 'VBGLU.INC'
INCLUDE 'CATS.INC'
INCLUDE 'CONTROL.INC'
INCLUDE 'INCS:DFIL.INC'
INCLUDE 'INCS:DMSG.INC'
INCLUDE 'INCS:DCAT.INC'
INCLUDE 'INCS:DHDR.INC'
INCLUDE 'INCS:DDCH.INC'
INCLUDE 'INCS:DUVH.INC'
DATA BLANK /' '/
DATA T, F /.TRUE.,.FALSE./
DATA ALUN /29/
C-----------------------------------------------------------------------
C Init for AIPS, disks, ...
CALL ZDCHIN (T)
CALL VHDRIN
NUMHIS = 0
C Initialize /CFILES/
NSCR = 0
NCFILE = 0
JERR = 0
C Get input parameters.
NPARM = 35
CALL GTPARM (PRGN, NPARM, RQUICK, XNAME1, BUFFI(1,1), IERR)
IF (IERR.NE.0) THEN
RQUICK = .TRUE.
JERR = 8
IF (IERR.EQ.1) GO TO 999
WRITE (MSGTXT,1000) IERR
CALL MSGWRT (8)
END IF
C Restart AIPS
IF (RQUICK) CALL RELPOP (JERR, BUFFI(1,1), IERR)
IF (JERR.NE.0) GO TO 999
JERR = 5
C Crunch input parameters.
CALL H2CHR (12, 1, XNAME1, NAMEI(1))
CALL H2CHR (6, 1, XCLAS1, CLASI(1))
CALL H2CHR (12, 1, XNAME2, NAMEI(2))
CALL H2CHR (6, 1, XCLAS2, CLASI(2))
CALL H2CHR (12, 1, XNAME3, NAMEI(3))
CALL H2CHR (6, 1, XCLAS3, CLASI(3))
CALL H2CHR (12, 1, XNAME4, NAMEI(4))
CALL H2CHR (6, 1, XCLAS4, CLASI(4))
CALL H2CHR (12, 1, XNAMOU, NAMOUT)
CALL H2CHR (6, 1, XCLAOU, CLAOUT)
SEQI(1) = IROUND (XS1)
SEQI(2) = IROUND (XS2)
SEQI(3) = IROUND (XS3)
SEQI(4) = IROUND (XS4)
SEQOUT = IROUND (XSOUT)
DISKI(1) = IROUND (XDISK1)
DISKI(2) = IROUND (XDISK2)
DISKI(3) = IROUND (XDISK3)
DISKI(4) = IROUND (XDISK4)
DISKO = IROUND (XDISO)
GLU3 = F
GLU4 = F
CALL FILL (4, 0, NIFI)
NVISO = 0
C Create new file.
C Get CATBLK from files.
PTYPE = 'UV'
DO 20 I = 1, 4
IF (NAMEI(I).EQ.' ') GO TO 20
CNOI(I) = 1
CALL CATDIR ('SRCH', DISKI(I), CNOI(I), NAMEI(I), CLASI(I),
* SEQI(I),PTYPE, NLUSER, STAT, BUFFI, IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1030) IERR, NAMEI(I), CLASI(I), SEQI(I),
* DISKI(I), NLUSER
GO TO 990
END IF
CALL CATIO ('READ', DISKI(I), CNOI(I), CATI(1,I),
* 'REST', BUFFI(1,1), IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1040) IERR
GO TO 990
END IF
C Determine input data file
C characteristics
CALL COPY (256, CATI(1,I), CATBLK)
CALL UVPGET (JERR)
IF (JERR.NE.0) GO TO 999
C Save input file info
INCX = CATBLK(KINAX)
LRECI(I) = LREC
NRPRMI(I) = NRPARM
INCSI(I) = INCS / INCX
INCFI(I) = INCF / INCX
INCIFI(I) = INCIF / INCX
NVISIN(I) = NVIS
20 CONTINUE
C Save input CATBLK, => output
CALL COPY (256, CATI(1,1), CATBLK)
C max antenna number
CALL GETNAN (DISKI, CNOI, CATBLK, ALUN, BUFFI, NUMAN, IERR)
ANTMAX = NUMAN(2)
C Are there 3rd and 4th files,
C NAMEI(3) & NAMEI(4) should be non
C blank
NUMFIL = 2
IF (NAMEI(3).NE.' ') THEN
GLU3 = T
NUMFIL = 3
END IF
IF (NAMEI(4).NE.' ') THEN
GLU4 = T
NUMFIL = 4
END IF
C # visibilities
NVISO = CATI(KIGCN,1)
DO 30 INUM = 2, NUMFIL
IF (CATI(KIGCN,INUM).GT.NVISO) THEN
WRITE (MSGTXT,2020) INUM, CATI(KIGCN,INUM), NVISO
CALL MSGWRT (6)
END IF
30 CONTINUE
C Set up some indices
CALL AXEFND (8, 'DEC ', CATI(KIDIM,1), CATHI(KHCTP,1),
* ILOCDE, JERR)
CALL AXEFND (8, 'RA ', CATI(KIDIM,1), CATHI(KHCTP,1),
* ILOCRA, JERR)
CALL AXEFND (8, 'STOKES ', CATI(KIDIM,1), CATHI(KHCTP,1),
* ILOCS, JERR)
IF (JERR.NE.0) THEN
NSTOKS = 0
ELSE
NSTOKS = CATI(KINAX+ILOCS,1)
END IF
CALL AXEFND (8, 'IF ', CATI(KIDIM,1), CATHI(KHCTP,1),
* ILOCIF, JERR)
IF (JERR.NE.0) THEN
MSGTXT = 'NO IF AXIS - NOTHING FOR ME TO DO'
JERR = 1
GO TO 990
ELSE
NIFI(1) = CATI(KINAX+ILOCIF,1)
NIFI(2) = CATI(KINAX+ILOCIF,2)
NIFI(3) = CATI(KINAX+ILOCIF,3)
NIFI(4) = CATI(KINAX+ILOCIF,4)
END IF
CALL AXEFND (8, 'FREQ ', CATI(KIDIM,1), CATHI(KHCTP,1),
* ILOCF, JERR)
IF (JERR.NE.0) THEN
NCHAN = 0
ELSE
NCHAN = CATI(KINAX+ILOCF,1)
END IF
C Check observing date, #rps,
C # complex axes, sort order
C File 1 & 2
DO 50 INUM = 2, NUMFIL
C Compare Hollerith strings
CALL CHCOMP (8, 1, CATHI(KHDOB,1), 1, CATHI(KHDOB,INUM), WEQ1)
CALL CHCOMP (2, 1, CATHI(KITYP,1), 1, CATHI(KITYP,INUM), WEQ2)
IF ((.NOT.WEQ1).OR.(CATI(KIPCN,1).NE.CATI(KIPCN,INUM)).OR.
* (CATI(KINAX,1).NE.CATI(KINAX,INUM)).OR.(.NOT.WEQ2)) THEN
WRITE (MSGTXT,1170) INUM
JERR = 1
GO TO 990
END IF
C Check random parameters
DO 40 J = 1, CATI(KIPCN,1)
C Compare Hollerith strings
CALL CHCOMP (8, 1, CATHI((KHPTP+(I-1)*2),1), 1,
* CATHI((KHPTP+(I-1)*2),INUM), WEQ1)
IF (.NOT.WEQ1) THEN
WRITE (MSGTXT,1100) INUM, J
JERR = 1
GO TO 990
END IF
40 CONTINUE
C Check coordinates
IF ((ABS(CATDI(KDCRV+ILOCDE,1) -
* CATDI(KDCRV+ILOCDE,INUM)) .GT. .01) .OR.
* (ABS(CATDI(KDCRV+ILOCRA,1) -
* CATDI(KDCRV+ILOCRA,INUM))) .GT. .01) THEN
WRITE (MSGTXT,1110) INUM
JERR = 1
GO TO 990
END IF
C Make sure # stokes & spectral
C channels the same. Store
C # IFs.
C # channels
IF (NCHAN.NE.CATI(KINAX+ILOCF,INUM)) THEN
WRITE (MSGTXT,1120) INUM
JERR = 1
GO TO 990
END IF
C # Stokes
IF (NSTOKS.NE.CATI(KINAX+ILOCS,INUM)) THEN
WRITE (MSGTXT,1130) INUM
JERR = 1
GO TO 990
END IF
50 CONTINUE
C Compressed data?
ISCOMP = CATBLK(KINAX).EQ.1
IF (ISCOMP) THEN
C Find weight and scale.
CALL AXEFND (8, 'WEIGHT ', CATBLK(KIPCN), CATH(KHPTP), ILOCWT,
* JERR)
IF (JERR.NE.0) THEN
MSGTXT = 'ERROR FINDING WEIGHT FOR COMPRESSED DATA'
JERR = 9
GO TO 990
END IF
CALL AXEFND (8, 'SCALE ', CATBLK(KIPCN), CATH(KHPTP), ILOCSC,
* JERR)
IF (JERR.NE.0) THEN
MSGTXT = 'ERROR FINDING SCALE FOR COMPRESSED DATA'
JERR = 9
GO TO 990
END IF
END IF
C Put new values in CATBLK.
CALL MAKOUT (NAMEI(1), CLASI(1), SEQI(1), BLANK, NAMOUT,
* CLAOUT, SEQOUT)
CALL CHR2H (12, NAMOUT, KHIMNO, CATH(KHIMN))
CALL CHR2H (6, CLAOUT, KHIMCO, CATH(KHIMC))
CATBLK(KIIMS) = SEQOUT
C Calculate # output IFs
NIFO = NIFI(1) + NIFI(2) + NIFI(3) + NIFI(4)
CATBLK(KINAX+ILOCIF) = NIFO
CATBLK(KIGCN) = NVISO
C Create output file.
CCNO = 1
FRW(NCFILE+1) = 3
JERR = 4
CALL UVCREA (DISKO, CCNO, BUFFO, IERR)
IF (IERR.NE.0) THEN
IF (IERR.NE.2) THEN
WRITE (MSGTXT,1050) IERR
GO TO 990
END IF
C Only overwrite Input file
C no destroy existing otherwise
IF ((CCNO.NE.CNOI(1)) .OR. (DISKO.NE.DISKI(1))) THEN
WRITE (MSGTXT,1060)
GO TO 990
END IF
C Recover existing CATBLK
FRW(NCFILE+1) = 2
CALL CATIO ('READ', DISKO, CCNO, CATBLK, 'WRIT', BUFFO, IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1065) IERR
CALL MSGWRT (6)
END IF
END IF
NCFILE = NCFILE + 1
FVOL(NCFILE) = DISKO
FCNO(NCFILE) = CCNO
FRW(NCFILE) = FRW(NCFILE) - 1
C Save output file info
CALL UVPGET (JERR)
IF (JERR.NE.0) GO TO 999
INCX = CATBLK(KINAX)
LRECO = LREC
NRPRMO = NRPARM
INCSO = INCS / INCX
INCFO = INCF / INCX
INCIFO = INCIF / INCX
C Put input file in READ
PTYPE = 'UV'
DO 80 I = 1, NUMFIL
CALL CATDIR ('CSTA', DISKI(I), CNOI(I), NAMEI(I), CLASI(I),
* SEQI(I), PTYPE, NLUSER, 'READ', BUFFI, IERR)
IF (IERR.NE.0) THEN
JERR = IERR
WRITE (MSGTXT,1180) IERR, I
GO TO 990
END IF
NCFILE = NCFILE + 1
FVOL(NCFILE) = DISKI(I)
FCNO(NCFILE) = CNOI(I)
FRW(NCFILE) = 0
80 CONTINUE
C
JERR = 0
SEQOUT = CATBLK(KIIMS)
C Ensure all files have NX tables
DO 100 INUM = 1, NUMFIL
CALL FNDEXT ('NX', CATI(1,INUM), NNX)
IF (NNX.EQ.0) THEN
WRITE (MSGTXT,1150) INUM
JERR = 1
GO TO 990
END IF
100 CONTINUE
C Check start & stop times of
C each file to ensure some overlap
C Also determine which one starts
C first.
DO 130 INUM = 1,NUMFIL
CALL UVTIME (DISKI(INUM), CNOI(INUM), CATI(1,INUM), TBI(INUM),
* TSI(INUM), JERR)
IF (JERR.NE.0) THEN
WRITE (MSGTXT,1140) INUM
GO TO 990
END IF
CALL TODHMS (TBI(INUM), TIM1)
CALL TODHMS (TSI(INUM), TIM2)
WRITE (MSGTXT,1010) NAMEI(INUM), CLASI(INUM), SEQI(INUM),
* DISKI(INUM)
CALL MSGWRT (4)
WRITE (MSGTXT,1020) TIM1, TIM2, CATI(KIGCN,INUM)
CALL MSGWRT (4)
130 CONTINUE
C Ensure all files have FQ tables
DO 160 INUM = 1, NUMFIL
CALL FNDEXT ('FQ', CATI(1,INUM), NFQ)
IF (NFQ.EQ.0) THEN
WRITE (MSGTXT,1160) INUM
JERR = 1
GO TO 990
END IF
160 CONTINUE
C Get IF info to decide on
C ordering.
CALL DFILL (MAXIF, -1.D0, FRQO)
CALL FILL (MAXIF, 0, ORDER)
IFRQ = 0
FQLUN = 40
IVER = 1
FREQID = 1
DO 220 INUM = 1, NUMFIL
CALL CHNDAT ('READ', BUFFI(1,INUM), DISKI(INUM), CNOI(INUM),
* IVER, CATI(1,INUM), FQLUN, NIFI(INUM), FOFFI(1,INUM),
* ISBI(1,INUM), FINCI(1,INUM), FREQID, JERR)
IF (JERR.NE.0) THEN
WRITE (MSGTXT,1190) JERR, INUM
GO TO 990
END IF
DO 200 I = 1, NIFI(INUM)
FRQI(I,INUM) = CATDI(KDCRV+JLOCF,INUM) + FOFFI(I,INUM)
IFRQ = IFRQ + 1
FRQO(IFRQ) = FRQI(I,INUM)
200 CONTINUE
220 CONTINUE
C Determine the output order
CALL DETORD (FRQO, NIFO, ORDER)
DO 230 I = 1, NIFO
IF (ORDER(I).LE.NIFI(1)) ORDER(I) = ORDER(I) + 100
IF ((ORDER(I).GT.NIFI(1)) .AND.
* (ORDER(I).LE.(NIFI(1)+NIFI(2))))
* ORDER(I) = ORDER(I) - NIFI(1) + 200
IF (GLU3) THEN
IF ((ORDER(I).GT.(NIFI(1)+NIFI(2))) .AND.
* (ORDER(I).LE.(NIFI(1) + NIFI(2) + NIFI(3))))
* ORDER(I) = ORDER(I) - (NIFI(1)+NIFI(2)) + 300
END IF
IF (GLU4) THEN
IF ((ORDER(I).GT.(NIFI(1) + NIFI(2) + NIFI(3))) .AND.
* (ORDER(I).LE.(NIFI(1) + NIFI(2) + NIFI(3)
* + NIFI(4))))
* ORDER(I) = ORDER(I) - (NIFI(1) + NIFI(2) + NIFI(3))
* + 400
END IF
230 CONTINUE
C Any uvw scaling?
CATD(KDCRV+JLOCF) = FRQO(1)
CALL DFILL (4, 1.D0, UVWSC)
DO 280 INUM = 1, NUMFIL
UVWSC(INUM) = CATD(KDCRV+JLOCF) / CATDI(KDCRV+JLOCF,INUM)
280 CONTINUE
C Write the output FQ table
C First fill in the arrays
DO 300 I = 1, NIFO
CALL GETORD (ORDER, I, INUM, J)
FOFFO(I) = FRQI(J,INUM) - CATD(KDCRV+JLOCF)
ISBO(I) = ISBI(J,INUM)
FINCO(I) = FINCI(J,INUM)
300 CONTINUE
CALL CHNDAT ('WRIT', BUFFO, DISKO, CCNO, IVER, CATBLK, FQLUN,
* NIFO, FOFFO, ISBO, FINCO, FREQID, JERR)
IF (JERR.NE.0) THEN
CALL TABERR ('WRIT', 'CHNDAT', 'VBGLIN', JERR)
GO TO 990
END IF
GO TO 999
C
990 CALL MSGWRT (8)
C
999 RETURN
C-----------------------------------------------------------------------
1000 FORMAT ('VBGLIN: ERROR',I3,' OBTAINING INPUT PARAMETERS')
1010 FORMAT ('File ',A12,'.',A6,'.',I4,' on disk ',I3,' covers')
1020 FORMAT ('time range ',I3,'/',3I3,' - ',
* I3,'/',3I3,' and has ',I8,' vis')
1030 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=',
* I3,' USID=',I5)
1040 FORMAT ('ERROR',I3,' COPYING CATBLK ')
1050 FORMAT ('ERROR',I3,' CREATING OUTPUT FILE')
1060 FORMAT ('MAY OVERWRITE INPUT FILE ONLY. QUITTING')
1065 FORMAT ('VBGLIN: ERROR',I3,' UPDATING NEW CATBLK')
1100 FORMAT ('VBGLIN: FILES 1 & ',I2,': R.P. #',I2,' MISMATCH')
1110 FORMAT ('VLBGIN: FILES 1 & ',I2,': RA/DEC MISMATCH')
1120 FORMAT ('VLBGIN: FILES 1 & ',I2,': # SPECTRAL CHANNELS MISMATCH')
1130 FORMAT ('VLBGIN: FILES 1 & ',I2,': # STOKES MISMATCH')
1140 FORMAT ('VLBGIN: ERROR DETERMING TIME RANGE FOR FILE ',I2)
1150 FORMAT ('VLBGIN: NO NX TABLE ATTACHED TO FILE ',I2)
1160 FORMAT ('VLBGIN: NO FQ TABLE ATTACHED TO FILE ',I2)
1170 FORMAT ('VLBGIN: FILES 1 & ',I2,' INCOMPATIBLE')
1180 FORMAT ('VLBGIN: ERROR ',I3,' CHANGING STATUS OF FILE ',I2)
1190 FORMAT ('VLBGIN: ERROR ',I3,' READING FQ TABLE FROM FILE ',I2)
2000 FORMAT ('Appending ',I3,' channels to get ',
* I3,' frequency channels')
2010 FORMAT ('from ',A12,'.',A8,';',I3,
* ' after a check of the headers')
2020 FORMAT ('File',I2,' has ',I7,' vis. File 1 only has ',I7)
END
SUBROUTINE DETORD (BANDFR, NOBAND, ORDER)
C-----------------------------------------------------------------------
C Routine to determine the order of frequencies.
C Input:
C BANDFR D(*) IF sky freqs
C NOBAND I # IF'S
C Output:
C ORDER I(*) Order of frequencies
C-----------------------------------------------------------------------
INCLUDE 'INCS:PUVD.INC'
DOUBLE PRECISION BANDFR(MAXIF), T1
INTEGER NOBAND, ORDER(MAXIF), I, J, K, II
C-----------------------------------------------------------------------
C Sort them into increasing order,
C ensuring deal with offsets that
C are the same.
DO 10 I = 1, NOBAND
ORDER(I) = I
10 CONTINUE
C
K = NOBAND - 1
DO 300 II = 1, NOBAND
DO 250 I = 1, K
IF (BANDFR(I+1).LT.BANDFR(I)) THEN
J = ORDER(I)
ORDER(I) = ORDER(I+1)
ORDER(I+1) = J
T1 = BANDFR(I)
BANDFR(I) = BANDFR(I+1)
BANDFR(I+1) = T1
END IF
250 CONTINUE
300 CONTINUE
C
RETURN
END
SUBROUTINE VBGHIS
C-----------------------------------------------------------------------
C VBGHIS copies and updates history file. It also copies any tables.
C
C Inputs in common (partial)
C NCFILE I Number of catalogue files read or write locked
C Will be equal to the number of input files + 1
C FCNO I(*) Catalogue numbers for locked files
C FCNO(1) is the output file, FCNO(2..NCFILE)
C are the input files.
C-----------------------------------------------------------------------
INTEGER NONOT
PARAMETER (NONOT = 12)
CHARACTER NOTTYP(NONOT)*2, HILINE*72, LABEL*8
INTEGER LUN1, LUNO, IERR, I
INCLUDE 'VBGLU.INC'
INCLUDE 'INCS:DMSG.INC'
INCLUDE 'INCS:DFIL.INC'
INCLUDE 'INCS:DHIS.INC'
INCLUDE 'INCS:DCAT.INC'
DATA LUN1, LUNO /27,28/
DATA NOTTYP /'FQ','AT','IM','CL','SN','MC','TY','PC','BP','BL',
* 'SU', 'CQ'/
C-----------------------------------------------------------------------
C Write History.
CALL HIINIT (3)
C Copy history records from first
C input file to output file:
CALL HISCOP (LUN1, LUNO, DISKI(1), DISKO, FCNO(2), FCNO(1),
* CATBLK, BUFFI, BUFFO, IERR)
IF (IERR.GT.2) THEN
WRITE (MSGTXT,1000) IERR
CALL MSGWRT (6)
GO TO 200
END IF
C New history
CALL HENCO1 (TSKNAM, NAMEI(1), CLASI(1), SEQI(1), DISKI(1),
* LUNO, BUFFI, IERR)
IF (IERR.NE.0) GO TO 200
CALL HENCOO (TSKNAM, NAMOUT, CLAOUT, SEQOUT, DISKO, LUNO,
* BUFFI, IERR)
IF (IERR.NE.0) GO TO 200
C Add any other history.
IF (NUMHIS .GT. 0) THEN
WRITE (LABEL,1010) TSKNAM
DO 50 I = 1,NUMHIS
HILINE = LABEL // HISCRD(I)
CALL HIADD (LUNO, HILINE, BUFFI, IERR)
IF (IERR.NE.0) GO TO 200
50 CONTINUE
END IF
C Close HI file
200 CALL HICLOS (LUNO, .TRUE., BUFFI, IERR)
C Copy tables
CALL ALLTAB (NONOT, NOTTYP, LUN1, LUNO, DISKI(1), DISKO,
* FCNO(2), FCNO(1), CATBLK, BUFFI, BUFFO, IERR)
IF (IERR.GT.2) THEN
WRITE (MSGTXT,1200)
CALL MSGWRT (6)
END IF
C Update CATBLK for output file.
CALL CATIO ('UPDT', DISKO, FCNO(1), CATBLK, 'REST',
* BUFFI, IERR)
C
999 RETURN
C-----------------------------------------------------------------------
1000 FORMAT ('VBGHIS: ERROR',I3,' COPY/OPEN HISTORY FILE')
1010 FORMAT (A6,' /')
1200 FORMAT ('VBGHIS: ERROR COPYING TABLES')
END
SUBROUTINE GETORD (ORDER, OUTIF, INFIL, INIF)
C-----------------------------------------------------------------------
C Little function that cracks the order code to give the input file
C and IF that correspond to the new output IF.
C-----------------------------------------------------------------------
INTEGER ORDER(*), OUTIF, INFIL, INIF
C-----------------------------------------------------------------------
INFIL = ORDER(OUTIF) / 100
INIF = ORDER(OUTIF) - INFIL * 100
RETURN
END
SUBROUTINE GLUDAT (IERR)
C-----------------------------------------------------------------------
C Routine that opens up the input files and the output file and handles
C the bookkeeping for the glueing process
C
C Output:
C IERR I Error code, 0 => OK
C-----------------------------------------------------------------------
INTEGER IERR
C
INCLUDE 'VBGLU.INC'
INCLUDE 'CATS.INC'
INCLUDE 'CONTROL.INC'
CHARACTER FILIN(4)*48, FILOUT*48
LONGINT BUFPT, ZBUFPT
INTEGER LUNIN(4), INUM, INDIN(4), ILENBU(4), IBIND(4), OBIND,
* VO, VOOUT, BO, INIO(4), NCORI(4), NCORO, NICOPY(4), NOCOPY,
* IPT, OPT, I, NIOUT, NIOLIM, VICNT(4), VOCNT, ONIO, IMAT(4),
* START(4), STOP(4), OLENBU, LUNOUT, INDOUT, IOUT, NOMATC, NCNTR,
* FNIO
REAL TBUFF(UVBFSL), RESULT(UVBFSL), ROUTIM(MAXBAS),
* BASOUT(MAXBAS), BUFALL(2), T1, T2
LOGICAL T, F, EOF(4), NEXT, FPASS
INCLUDE 'INCS:DMSG.INC'
INCLUDE 'INCS:DFIL.INC'
INCLUDE 'INCS:DHDR.INC'
INCLUDE 'INCS:DUVH.INC'
INCLUDE 'INCS:DCAT.INC'
DATA LUNIN /40, 41, 42, 43/
DATA T, F /.TRUE., .FALSE./
C-----------------------------------------------------------------------
VO = 0
BO = 1
LUNOUT = 44
JBUFSZ = UVBFSL * 2
EOF(1) = F
EOF(2) = F
EOF(3) = F
EOF(4) = F
JLOCT = ILOCT
JLOCB = ILOCB
JLOCIT = ILOCIT
FPASS = T
C allocate memory
I = MAX (NIFI(1), NIFI(2), NIFI(3), NIFI(4))
OUTSIZ = (3 * NSTOKS * NCHAN * I + NRPRMO) *
* (ANTMAX * (ANTMAX+1)) / 2 + UVBFSL*2 + 1024
CALL ZMEMRY ('GET ', 'GLUDAT', OUTSIZ, BUFALL, ZBUFPT, IERR)
IF (IERR.NE.0) THEN
MSGTXT = 'CANNOT GET NEEDED MEMORY'
CALL MSGWRT (8)
GO TO 999
END IF
C Record sizes in input
C and output files.
DO 10 INUM = 1, NUMFIL
NCORI(INUM) = (LRECI(INUM) - NRPRMI(INUM)) / CATI(KINAX,INUM)
NICOPY(INUM) = (LRECI(INUM) - NRPRMI(INUM)) / NIFI(INUM)
IF (ISCOMP) NICOPY(INUM) = NICOPY(INUM) * 3
10 CONTINUE
NCORO = (LRECO - NRPRMO) / CATBLK(KINAX)
NOCOPY = LRECO - NRPRMO
C Open and init for read
C all input files.
DO 40 INUM = 1,NUMFIL
CALL ZPHFIL ('UV', DISKI(INUM), CNOI(INUM), 1, FILIN(INUM),
* IERR)
CALL ZOPEN (LUNIN(INUM), INDIN(INUM), DISKI(INUM), FILIN(INUM),
* T, F, F, IERR)
IF (IERR.GT.0) THEN
WRITE (MSGTXT,1000) IERR, INUM
GO TO 990
END IF
ILENBU(INUM) = 0
CALL UVINIT ('READ', LUNIN(INUM), INDIN(INUM), NVISIN(INUM),
* VO, LRECI(INUM), ILENBU(INUM), JBUFSZ, BUFFI(1,INUM), BO,
* IBIND(INUM), IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1020) IERR, INUM
GO TO 990
END IF
40 CONTINUE
C Open the output file
CALL ZPHFIL ('UV', DISKO, CCNO, 1, FILOUT, IERR)
CALL ZOPEN (LUNOUT, INDOUT, DISKO, FILOUT, T, F, F, IERR)
IF (IERR.GT.0) THEN
WRITE (MSGTXT,1010) IERR
GO TO 990
END IF
OLENBU = 0
CALL UVINIT ('WRIT', LUNOUT, INDOUT, NVISO, VO, LRECO,
* OLENBU, JBUFSZ, BUFFO, BO, OBIND, IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1030) IERR, INUM
GO TO 990
END IF
OPT = OBIND
NIOUT = 0
NIOLIM = OLENBU
C Now we run through the 1st data
C file and load up the output
C buffer. This is the easy one.
INUM = 1
NUMVIS(INUM) = 0
100 CALL UVDISK ('READ', LUNIN(INUM), INDIN(INUM), BUFFI(1,INUM),
* INIO(INUM), IBIND(INUM), IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1040) IERR, INUM
GO TO 990
END IF
IPT = IBIND(INUM)
C EOF?
IF (INIO(INUM).LE.0) EOF(INUM) = T
IF (EOF(INUM)) GO TO 250
C Copy buffer
DO 200 I = 1, INIO(INUM)
NUMVIS(INUM) = NUMVIS(INUM) + 1
C Compressed
IF (ISCOMP) THEN
CALL ZUVXPN (NCORI(INUM), BUFFI((IPT+NRPRMI(INUM)),INUM),
* BUFFI((IPT+ILOCWT),INUM), TBUFF)
CALL LOADIF (FPASS, ORDER, NIFO, INUM, NICOPY(INUM),
* TBUFF, RESULT)
CALL ZUVPAK (NCORO, RESULT, BUFFO(OPT+ILOCWT),
* BUFFO(OPT+NRPRMO))
ELSE
C Uncompressed
CALL LOADIF (FPASS, ORDER, NIFO, INUM, NICOPY(INUM),
* BUFFI((IPT+NRPRMI(INUM)),INUM), BUFFO(OPT+NRPRMO))
END IF
C Copy over the random parameters
IF (ISCOMP) THEN
T1 = BUFFO(OPT+ILOCWT)
T2 = BUFFO(OPT+ILOCSC)
END IF
CALL RCOPY (NRPRMO, BUFFI(IPT,INUM), BUFFO(OPT))
IF (ISCOMP) THEN
BUFFO(OPT+ILOCWT) = T1
BUFFO(OPT+ILOCSC) = T2
END IF
C uvw scaling
BUFFO(OPT+ILOCU) = BUFFO(OPT+ILOCU) * UVWSC(INUM)
BUFFO(OPT+ILOCV) = BUFFO(OPT+ILOCV) * UVWSC(INUM)
BUFFO(OPT+ILOCW) = BUFFO(OPT+ILOCW) * UVWSC(INUM)
C update pointers
IPT = IPT + LRECI(INUM)
OPT = OPT + LRECO
NIOUT = NIOUT + 1
C Write if buffer full
IF (NIOUT.GE.NIOLIM) THEN
CALL UVDISK ('WRIT', LUNOUT, INDOUT, BUFFO, NIOLIM, OBIND,
* IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1050) IERR
GO TO 990
END IF
OPT = OBIND
NIOUT = 0
END IF
200 CONTINUE
C Read next buffer
GO TO 100
C Finish write
250 NIOUT = - NIOUT
CALL UVDISK ('FLSH', LUNOUT, INDOUT, BUFFO, NIOUT, OBIND, IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1050) IERR
GO TO 990
END IF
C Compress output file.
CALL UCMPRS (NUMVIS(INUM), DISKO, CCNO, LUNOUT, CATBLK, IERR)
C Close files
CALL ZCLOSE (LUNIN(INUM), INDIN(INUM), IERR)
IERR = 0
FPASS = F
C Now comes the hard part. We have
C to run through the output data
C stream 1) read a buffer full;
C 2) find the appropriate data
C from the input streams;
C 3) fill in the gaps in the
C output buffer; 4) reinit the
C output buffer for write and
C write it; 5) reinit for read and
C read the next buffer etc etc.
C
C Now have to run through the
C input data streams and fill up
C the output buffer with the IFs,
C when output buffer is filled
C must ensure it gets fully
C written.
C Do them all simultaneously so
C don't have to keep redoing the
C main output buffer.
C Find match in baseline & time
C for input & output data streams.
DO 500 INUM = 2, NUMFIL
C Initialize buffer control
GOTTIM = -999.0
FINTIM = -999.0
BUFPTR = 1
ICOP = 0
RINTIM(1) = -1.0
NOMATC = 0
VOOUT = 0
NCNTR = 0
ONIO = 0
CALL PREPOU (LUNOUT, INDOUT, BUFFO, OLENBU, OBIND, LRECO,
* NRPRMO, JBUFSZ, NVISO, VOOUT, ROUTIM, BASOUT, VOCNT, ONIO,
* IERR)
IF (IERR.EQ.4) THEN
IERR = 0
GO TO 800
END IF
IF (IERR.GT.0) GO TO 999
OPT = OBIND
C Initialize reading for input
C stream INUM.
ILENBU(INUM) = 0
CALL UVINIT ('READ', LUNIN(INUM), INDIN(INUM), NVISIN(INUM),
* VO, LRECI(INUM), ILENBU(INUM), JBUFSZ, BUFFI(1,INUM), BO,
* IBIND(INUM), IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1020) IERR, INUM
GO TO 990
END IF
C
IF (EOF(INUM)) GO TO 500
C
350 DO 400 IOUT = 1,ONIO
NCNTR = NCNTR + 1
C Get updated buffer from input
C stream
CALL GETDAT (ROUTIM(IOUT), LUNIN(INUM), INDIN(INUM),
* BUFFI(1,INUM), LRECI(INUM), START(INUM), STOP(INUM),
* VICNT(INUM), BUFALL(1+ZBUFPT), EOF(INUM), NEXT, IERR)
IF (NEXT) THEN
OPT = OPT + LRECO
GO TO 400
END IF
C Find match
CALL DAMATC (ROUTIM(IOUT), BASOUT(IOUT), VICNT(INUM),
* START(INUM), STOP(INUM), IMAT(INUM))
C Meaning if IMAT
C 0 => no time match but within
C the timeranges of the array.
C -1 => get next time from
C output data stream
C -2 => get next buffer from
C input data stream
C -3 => time matched but no
C baseline match
IF (IMAT(INUM).GT.0) THEN
C Found a match, fill in the
C blanks
BUFPT = 1 + ZBUFPT + (IMAT(INUM)-1) * LRECI(INUM)
C Compressed
IF (ISCOMP) THEN
CALL ZUVXPN (NCORO, BUFFO(OPT+NRPRMO),
* BUFFO(OPT+ILOCWT), RESULT)
CALL ZUVXPN (NCORI(INUM), BUFALL(BUFPT+NRPRMI(INUM)),
* BUFALL(BUFPT+ILOCWT), TBUFF)
CALL LOADIF (FPASS, ORDER, NIFO, INUM, NICOPY(INUM),
* TBUFF, RESULT)
CALL ZUVPAK (NCORO, RESULT, BUFFO(OPT+ILOCWT),
* BUFFO(OPT+NRPRMO))
C Uncompressed
ELSE
CALL LOADIF (FPASS, ORDER, NIFO, INUM, NICOPY(INUM),
* BUFALL(BUFPT+NRPRMI(INUM)), BUFFO(OPT+NRPRMO))
END IF
END IF
IF (IMAT(INUM).LE.0) NOMATC = NOMATC + 1
C
OPT = OPT + LRECO
400 CONTINUE
C Write the full output buffer.
FNIO = -OLENBU
CALL UVDISK ('FLSH', LUNOUT, INDOUT, BUFFO, FNIO, OBIND,
* IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1050) IERR
GO TO 990
END IF
CALL PREPOU (LUNOUT, INDOUT, BUFFO, OLENBU, OBIND, LRECO,
* NRPRMO, JBUFSZ, NVISO, VOOUT, ROUTIM,
* BASOUT, VOCNT, ONIO, IERR)
IF (IERR.EQ.4) THEN
IERR = 0
GO TO 800
END IF
IF (IERR.GT.0) GO TO 999
OPT = OBIND
GO TO 350
500 CONTINUE
C Tidy up
800 CALL ZCLOSE (LUNOUT, INDOUT, IERR)
DO 810 INUM = 2, NUMFIL
CALL ZCLOSE (LUNIN(INUM), INDIN(INUM), IERR)
810 CONTINUE
WRITE (MSGTXT,1080) NCNTR
CALL MSGWRT (4)
WRITE (MSGTXT,1090) NOMATC
IF (NOMATC.GT.0) CALL MSGWRT (4)
c
CALL ZMEMRY ('FREE', 'GLUDAT', OUTSIZ, BUFALL, ZBUFPT, IERR)
IERR = 0
GO TO 999
C Error
990 CALL MSGWRT (8)
C
999 RETURN
C-----------------------------------------------------------------------
1000 FORMAT ('GLUDAT: ERROR',I3,' OPEN-FOR-READ FILE ',I3)
1010 FORMAT ('GLUDAT: ERROR',I3,' OPEN-FOR-WRITE OUTPUT FILE')
1020 FORMAT ('GLUDAT: ERROR',I3,' INIT-FOR-READ FILE ',I3)
1030 FORMAT ('GLUDAT: ERROR',I3,' INIT-FOR-WRITE OUTPUT FILE')
1040 FORMAT ('GLUDAT: ERROR',I3,' READING FILE ',I3)
1050 FORMAT ('GLUDAT: ERROR',I3,' WRITING FILE')
1060 FORMAT ('GLUDAT: ERROR',I3,' READING OUTPUT FILE')
1070 FORMAT ('GLUDAT: ERROR',I3,' INIT-FOR-READ OUTPUT FILE')
1080 FORMAT ('Wrote ',I8,' spectrally merged visibilities')
1090 FORMAT (6X,I8,' of which will have some blanked IFs')
END
SUBROUTINE DAMATC (ROUTIM, BASOUT, NENT, START, STOP, MATCH)
C-----------------------------------------------------------------------
C Routine to search through the index of times & baseline numbers from
C the output file to see if there is a match with the data coming from
C the input stream.
C Inputs:
C ROUTIM R Output stream time (days) to be matched
C BASOUT R Output stream baseline number to be matched
C NENT I # entries in RINTIM & BASIN
C START I Entry number from which to start searching
C STOP I Entry number at which to stop searching
C Input from common:
C RINTIM R(*) Input stream time array, contains the time
C (days) of all data in the current buffer.
C BASIN R(*) Input stream baseline numbers
C INTTIM R(*) Integration time (days) of record
C Output:
C MATCH I The matching index number in the output
C data stream. If = 0, no time
C match but within the timeranges
C of the array.
C If = -1, get next time from
C output data stream
C If = -2, get next buffer from
C input data stream
C If = -3, time matched but no
C baseline match
C-----------------------------------------------------------------------
INTEGER NENT, MATCH, I, START, STOP, IS, IF
REAL BASOUT, ROUTIM
DOUBLE PRECISION EPS, DIFF
INCLUDE 'CONTROL.INC'
C-----------------------------------------------------------------------
MATCH = 0
IS = START
IF = STOP
IF (IS.LE.0) IS = 1
IF (IF.LE.0) IF = NENT
C No matching times found in
C GETPTR.
IF ((START.EQ.0).OR.(STOP.EQ.0)) THEN
IF (ROUTIM.LT.RINTIM(IS)) THEN
MATCH = -1
GO TO 999
END IF
IF (ROUTIM.GT.RINTIM(IF)) THEN
MATCH = -2
GO TO 999
END IF
END IF
C Search for baseline match
DO 100 I = IS, IF
EPS = 0.1D0 * INTTIM(I)
DIFF = RINTIM(I) - ROUTIM
IF (DIFF.GT.EPS) GO TO 100
IF (ABS (DIFF) .LE. EPS) THEN
MATCH = -3
IF (BASOUT.EQ.BASIN(I)) THEN
MATCH = I
GO TO 999
END IF
END IF
100 CONTINUE
999 RETURN
END
SUBROUTINE GETDAT (TIME, LUN, IND, BUFFIN, LRECI, START, STOP,
* VICNT, BUFOUT, EOF, NEXT, IERR)
C-----------------------------------------------------------------------
C Routine to read an input data stream and ensure that all data for
C a given time is resident in BUFOUT. That buffer is then used to
C fill up the output data stream.
C Inputs:
C TIME R Time to be loaded
C LUN I LUN of input data file
C IND I FTAB pointer of input data file
C BUFFIN R(*) Buffer for input data loading
C LRECI I Length of record from input file
C Outputs:
C START I Record # in various arrays at which data
C with TIME start
C STOP I Record # in various arrays at which data
C with TIME stop
C VICNT I # records currently loaded in BUFOUT
C BUFOUT R(*) Buffer for output data
C EOF L If true then EOF found on input file
C NEXT L If true then get next time from big file
C IERR I Error code.
C-----------------------------------------------------------------------
INTEGER LUN, IND, LRECI, VICNT, START, STOP, IERR
REAL TIME, BUFFIN(*), BUFOUT(*)
LOGICAL EOF, NEXT
C
INCLUDE 'CONTROL.INC'
INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
NEXT = .FALSE.
C Read uv file until find first
C time
IF (TIME.NE.GOTTIM) THEN
CALL GETBUF (TIME, LUN, IND, LRECI, BUFFIN, VICNT, EOF,
* BUFOUT, START, STOP, IERR)
IF (START.EQ.0) THEN
NEXT = .TRUE.
GO TO 999
END IF
END IF
GO TO 999
C
990 CALL MSGWRT (6)
C
999 RETURN
END
SUBROUTINE GETBUF (TIME, LUN, IND, LRECI, BUFFIN, VICNT, EOF,
* BUFOUT, START, STOP, IERR)
C-----------------------------------------------------------------------
C Routine to get all data for a given time.
C Inputs:
C TIME R Time to be loaded
C LUN I LUN of input data file
C IND I FTAB pointer of input data file
C LRECI I Length of record from input file
C BUFFIN R(*) Buffer for input data loading
C Input from common:
C GOTTIM R Denotes the time (days) currently being
C processed
C Outputs:
C VICNT I # records currently loaded in BUFOUT
C EOF L If true then EOF found on input file
C BUFOUT R(*) Buffer for output data
C START I Record # in various arrays at which data
C with TIME start
C STOP I Record # in various arrays at which data
C with TIME stop
C IERR I Error code.
C
C GOTTIM (days) denotes the time already stored in BUFOUT.
C START & STOP denote the pointers in BUFOUT for the data corresponding
C to TIME.
C-----------------------------------------------------------------------
INTEGER LUN, IND, INIO, IBIND, LRECI,
* VICNT, IERR, IPT, I, START, STOP, ICNT, N
REAL BUFFIN(*), BUFOUT(*), TIME, TMPTIM
LOGICAL EOF
INCLUDE 'CONTROL.INC'
INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C Do we need to do any work?
IF (TIME.EQ.GOTTIM) GO TO 999
C
IF (TIME.GT.FINTIM) GO TO 10
C
IF ((TIME.GT.GOTTIM) .AND. (RINTIM(1).GT.-1.0)) THEN
CALL GETPTR (TIME, VICNT, START, STOP, ICNT)
IF (START.LE.0) GO TO 999
GOTTIM = TIME
IF (STOP.LT.VICNT) GO TO 999
END IF
C read in a bunch of data
10 CALL UVDISK ('READ', LUN, IND, BUFFIN, INIO, IBIND, IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1000) IERR
GO TO 990
END IF
C EOF?
IF (INIO.LE.0) EOF = .TRUE.
IF (EOF) GO TO 999
ICOP = INIO*LRECI
C Recycle the buffer
IF ((BUFPTR+(2*ICOP)).GT.OUTSIZ) THEN
C START is the first visibility
C that is relevant to us.
I = 1 + (START-1) * LRECI
N = VICNT - START + 1
N = N * LRECI
CALL RCOPY (N, BUFOUT(I), BUFOUT(1))
ICOP = 0
VICNT = N / LRECI
IPT = 1
DO 30 I = 1, VICNT
RINTIM(I) = BUFOUT(IPT+JLOCT)
BASIN(I) = BUFOUT(IPT+JLOCB)
INTTIM(I) = BUFOUT(IPT+JLOCIT) / 86400.0
IPT = IPT + LRECI
30 CONTINUE
BUFPTR = VICNT * LRECI + 1
END IF
C
START = 0
STOP = 0
C Copy data to the main buffer
IF (BUFPTR-1+ICOP.GT.OUTSIZ) THEN
MSGTXT = 'BUFFER HAS OVERFLOWED - WE GOT BAD TROUBLE'
CALL MSGWRT (8)
IERR = 8
GO TO 999
END IF
CALL RCOPY (ICOP, BUFFIN(IBIND), BUFOUT(BUFPTR))
IPT = BUFPTR
BUFPTR = BUFPTR + ICOP
C Run through the buffer seeing if
C we have all the data we need.
DO 100 I = 1, INIO
IF ((I+VICNT).GT.MAXBAS) THEN
MSGTXT = 'GETBUF: INCREASE MAXBAS PARAMETER'
IERR = 1
GO TO 990
END IF
RINTIM(I+VICNT) = BUFOUT(IPT+JLOCT)
BASIN(I+VICNT) = BUFOUT(IPT+JLOCB)
INTTIM(I+VICNT) = BUFOUT(IPT+JLOCIT) / 86400.0
IPT = IPT + LRECI
100 CONTINUE
VICNT = VICNT + INIO
C Determine last full time
TMPTIM = RINTIM(VICNT)
DO 120 I = VICNT, 1, -1
IF (RINTIM(I).LT.TMPTIM) THEN
FINTIM = RINTIM(I)
GO TO 130
END IF
120 CONTINUE
C Get pointers
130 CALL GETPTR (TIME, VICNT, START, STOP, ICNT)
IF (START.LE.0) GO TO 999
GOTTIM = TIME
IF (STOP.LT.VICNT) GO TO 999
C Do we need more
IF (STOP.EQ.VICNT) THEN
GO TO 10
END IF
C
990 CALL MSGWRT (6)
C
999 RETURN
C-----------------------------------------------------------------------
1000 FORMAT ('GETBUF: ERROR',I3,' READING INPUT DATA')
END
SUBROUTINE GETPTR (TIME, NENT, START, STOP, ICNT)
C-----------------------------------------------------------------------
C Routine to determine how many entries in RINTIM match TIME.
C Inputs:
C TIME R Time to search for (days)
C NENT I # entries in RINTIM
C Inputs from common:
C RINTIM R(*) Time array to search
C INTTIM R(*) Integration time (days) of record
C Outputs:
C START I First entry that matches TIME
C STOP I Final entry that matches TIME
C ICNT I # entries that matches TIME
C-----------------------------------------------------------------------
INTEGER NENT, START, STOP, ICNT, I
REAL TIME
DOUBLE PRECISION EPS, DIFF
INCLUDE 'CONTROL.INC'
C-----------------------------------------------------------------------
ICNT = 0
START = 0
STOP = NENT
DO 50 I = 1, NENT
EPS = 0.1D0 * INTTIM(I)
DIFF = RINTIM(I) - TIME
IF (ABS (DIFF) .LE. EPS) ICNT = ICNT + 1
IF (ICNT.EQ.1) START = I
IF ((DIFF .GT. EPS) .AND. (STOP.EQ.NENT)) STOP = I - 1
IF (DIFF .GT. EPS) GO TO 999
50 CONTINUE
999 RETURN
END
SUBROUTINE PREPOU (LUNOUT, INDOUT, BUFFO, OLENBU, OBIND, LRECO,
* NRPRMO, JBUFSZ, NVISO, VOOUT, ROUTIM, BASOUT, VOCNT, ONIO,
* IERR)
C-----------------------------------------------------------------------
C Routine to handle the output uv file. The file needs to be opened
C 'READ', data read and then reopened 'WRIT'
C Inputs
C LUNOUT I LUN
C INDOUT I FTAB pointer
C BUFFO R(*) data buffer
C OLENBU I # records to read, 0 => UVINIT choose.
C OBIND I pointer in buffer for start of data
C LRECO I Length of output data record
C NRPRMO I # rps in output file
C JBUFSZ I size of BUFFO
C NVISO I # vis points in o/p file
C Outputs:
C VOOUT I vis offset this time around
C ROUTIM R(*) list of time for data currently in BUFFO
C BASOUT R(*) list of baseline numbers for data
C currently in BUFFO
C VOCNT I # entries in ROUTIM & BASOUT
C ONIO I # vis read this time
C IERR I Error code:
C 4 => EOF
C-----------------------------------------------------------------------
INTEGER LUNOUT, INDOUT, OLENBU, OBIND, LRECO, JBUFSZ,
* NVISO, VOOUT, VOCNT, ONIO, NRPRMO, IERR
REAL BUFFO(*), ROUTIM(*), BASOUT(*)
C
INTEGER TVISN, I, OPT, BO
INCLUDE 'CONTROL.INC'
INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
BO = 1
C Init for random access read
VOOUT = VOOUT + ONIO
TVISN = NVISO - VOOUT
C EOF?
IF (TVISN.LE.0) THEN
IERR = 4
GO TO 999
END IF
C
OLENBU = 0
CALL UVINIT ('READ', LUNOUT, INDOUT, TVISN, VOOUT, LRECO,
* OLENBU, JBUFSZ, BUFFO, BO, OBIND, IERR)
IF (IERR.EQ.4) THEN
GO TO 999
END IF
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1000) IERR
GO TO 990
END IF
OPT = OBIND
C Read it
ONIO = 0
CALL UVDISK ('READ', LUNOUT, INDOUT, BUFFO, ONIO, OBIND, IERR)
IF (IERR.EQ.4) THEN
GO TO 999
END IF
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1010) IERR
GO TO 990
END IF
VOCNT = 0
OPT = OBIND
C Get time and baseline #s in
C buffer
DO 100 I = 1, ONIO
VOCNT = VOCNT + 1
IF (VOCNT.GT.MAXBAS) THEN
MSGTXT = 'PREPOU: INCREASE MAXBAS PARAMETER'
IERR = 1
GO TO 990
END IF
ROUTIM(VOCNT) = BUFFO(OPT+JLOCT)
BASOUT(VOCNT) = BUFFO(OPT+JLOCB)
OPT = OPT + LRECO
100 CONTINUE
OPT = OBIND
C Reinit for writing
CALL UVINIT ('WRIT', LUNOUT, INDOUT, TVISN, VOOUT, LRECO,
* OLENBU, JBUFSZ, BUFFO, BO, OBIND, IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1020) IERR
GO TO 990
END IF
GO TO 999
C
990 CALL MSGWRT (6)
C
999 RETURN
C-----------------------------------------------------------------------
1000 FORMAT ('PREPOU: ERROR',I3,' INIT-FOR-READ OUTPUT FILE')
1010 FORMAT ('PREPOU: ERROR',I3,' READING OUTPUT FILE')
1020 FORMAT ('PREPOU: ERROR',I3,' INIT-FOR-WRITE OUTPUT FILE')
END
SUBROUTINE GLUTAB (IERR)
C-----------------------------------------------------------------------
C Routine that performs the bonding process for tables. Since there
C are so many tables that need operating on this will do it in a
C generic sense.
C
C Output:
C IERR I Error code, 0 => OK
C-----------------------------------------------------------------------
INTEGER IERR
C
INCLUDE 'VBGLU.INC'
INCLUDE 'CATS.INC'
INCLUDE 'CONTROL.INC'
INTEGER TABDO, MAXIFV, MAXKEY, MAXTWO, MAXIDC
PARAMETER (TABDO = 10, MAXIFV = 13, MAXKEY = 50)
PARAMETER (MAXTWO = 8, MAXIDC = 6)
CHARACTER TABGLU(TABDO)*2, TABIFS(MAXIFV,TABDO)*24,
* IFKEY(TABDO)*8, KEYWRD(MAXKEY)*8, TWODIM(MAXTWO,TABDO)*24,
* IDKOLS(MAXIDC,TABDO)*24
INTEGER I, NTAB, VER, LUNIN, LUNOUT, NKEY, NREC, NCOL,
* DATP(256), NROWS, COLKEY(TABDO), UNIQUE(TABDO),
* LOGCOL(MAXIFV,TABDO), INUM, BUFFER(512), BUFOUT(512),
* IROW, RECI(XBPRSZ), RECO(XBPRSZ), DATPO(256),
* ICOL, LENGTH, RTYPE, IPTR, OPTR, ITEMP(6),
* KLOCS(MAXKEY), KVALS(MAXKEY), KTYP(MAXKEY), DIMT(TABDO),
* TWOCOL(MAXTWO,TABDO), TWOKEY(TABDO), TWOLEN, NROWIN,
* IDKEY(TABDO), IDUNIQ(TABDO), IDCOL(MAXIDC), OSRC, OANT, OARR,
* OFQID, KROW, KSTART, ISRC, IANT, IARR, IFQID, INDEX(5),
* IDUM, NKY, NROWCP
REAL RECRI(XBPRSZ), RECRO(XBPRSZ), OITIME, IITIME, PERCOP
DOUBLE PRECISION RECDI(XBPRSZ/2), RECDO(XBPRSZ/2), OTIME,
* ITIME, INDTIM, EPS
LOGICAL WANKOL, FPASS, TWOD, EQUTM, EQUAN, EQUSU, EQUFQ, EQUAR
INCLUDE 'INCS:DMSG.INC'
INCLUDE 'INCS:DFIL.INC'
INCLUDE 'INCS:DDCH.INC'
INCLUDE 'INCS:DCAT.INC'
EQUIVALENCE (RECDI, RECI, RECRI)
EQUIVALENCE (RECDO, RECO, RECRO)
DATA TABGLU /'AT','IM','CL','SN','MC','TY','PC','BP','BL','SU' /
C AT IF columns
DATA TABIFS /'POLAA','POLCALA','POLAB','POLCALB',9*' ',
C IM IF columns
* 'FREQ.VAR','PDELAY_1','PRATE_1','PDELAY_2','PRATE_2',8*' ',
C CL IF columns
* 'DOPPOFF','REAL1','IMAG1','RATE 1','DELAY 1','WEIGHT 1',
* 'REFANT 1','REAL2','IMAG2','RATE 2','DELAY 2','WEIGHT 2',
* 'REFANT 2',
C SN IF columns
* 'REAL1','IMAG1','RATE 1','DELAY 1','WEIGHT 1','REFANT 1',
* 'REAL2','IMAG2','RATE 2','DELAY 2','WEIGHT 2','REFANT 2',' ',
C MC IF columns
* 'LO_OFFSET_1','DLO_OFFSET_1','LO_OFFSET_2','DLO_OFFSET_2',
* 9*' ',
C TY IF columns
* 'TSYS 1','TANT 1','TSYS 2','TANT 2',9*' ',
C PC IF columns
* 'PC_FREQ 1','PC_REAL 1','PC_IMAG 1','PC_RATE 1',
* 'PC_FREQ 2','PC_REAL 2','PC_IMAG 2','PC_RATE 2',5*' ',
C BP IF columns
* 'IF FREQ','REAL 1','IMAG 1','REAL 2','IMAG 2',8*' ',
C BL IF columns
* 'REAL M1','IMAG M1','REAL A1','IMAG A1',
* 'REAL M2','IMAG M2','REAL A2','IMAG A2',5*' ',
C SU IF columns
* 'IFLUX','QFLUX','UFLUX','VFLUX','FREQOFF','LSRVEL',
* 'RESTFREQ',6*' ' /
C Columns that are 2-D
C AT table
DATA TWODIM /'POLCALA','POLCALB',6*' ',
C IM table
* 'PDELAY_1','PRATE_1','PDELAY_2','PRATE_2',4*' ',
C CL table
* 8*' ',
C SN table
* 8*' ',
C MC table
* 8*' ',
C TY table
* 8*' ',
C PC table
* 'PC_FREQ 1','PC_REAL 1','PC_IMAG 1','PC_RATE 1',
* 'PC_FREQ 2','PC_REAL 2','PC_IMAG 2','PC_RATE 2',
C BP table
* 'REAL 1','IMAG 1','REAL 2','IMAG 2',4*' ',
C BL table
* 8*' ',
C SU table
* 8*' ' /
C # cols for different tables
DATA COLKEY /4, 5, 13, 12, 4, 4, 8, 5, 8, 7/
C # unique characters for search
DATA UNIQUE /7, 8, 8, 8, 12, 6, 9, 6, 7, 5/
C # 2-d cols for table
DATA TWOKEY /2, 4, 0, 0, 0, 0, 8, 4, 0, 0/
C IF keyword for different tables
DATA IFKEY /'NO_BAND ','NO_BAND ','NO_IF ','NO_IF ',
* 'NO_BAND ','NO_IF ','NO_BAND ','NO_IF ','NO_IF ',
* 'NO_IF ' /
C Cols needed for merging process
C AT table
DATA IDKOLS /'TIME','TIME_INTERVAL','SOURCE_ID','ANTENNA_NO',
* 'ARRAY','FREQID',
C IM table
* 'TIME','TIME_INTERVAL','SOURCE_ID','ANTENNA_NO','ARRAY',
* 'FREQID',
C CL table
* 'TIME','TIME INTERVAL','SOURCE ID','ANTENNA NO','SUBARRAY',
* 'FREQ ID',
C SN table
* 'TIME','TIME INTERVAL','SOURCE ID','ANTENNA NO','SUBARRAY',
* 'FREQ ID',
C MC table
* 'TIME','TIME_INTERVAL','SOURCE_ID','ANTENNA_NO','ARRAY',
* 'FREQID',
C TY table
* 'TIME','TIME INTERVAL','SOURCE ID','ANTENNA NO','SUBARRAY',
* 'FREQ ID',
C PC table
* 'TIME','TIME_INTERVAL','SOURCE_ID','ANTENNA_NO','ARRAY',
* 'FREQID',
C BP table
* 'TIME','INTERVAL','SOURCE ID','ANTENNA NO','SUBARRAY',
* 'FREQ ID',
C BL table
* 'TIME','SOURCE ID','ANTENNA1','ANTENNA2','FREQ ID',' ',
C SU table
* 'ID. NO.',5*' ' /
C # cols for different tables
DATA IDKEY /6, 6, 6, 6, 6, 6, 6, 6, 5, 1 /
C # unique characters for search
DATA IDUNIQ /8, 8, 8, 8, 8, 8, 8, 8, 8, 7 /
C-----------------------------------------------------------------------
LUNIN = 40
LUNOUT = 41
FPASS = .TRUE.
C First we copy the tables from
C the main file, expanding them
C to the correct # IFs.
INUM = 1
DO 200 I = 1, TABDO
TWOD = .FALSE.
CALL FNDEXT (TABGLU(I), CATI(1,INUM), NTAB)
IF (NTAB.EQ.0) GO TO 200
IF (TABGLU(I).EQ.'BL') THEN
MSGTXT = 'VBGLU cannot currently deal with BL tables'
CALL MSGWRT (6)
GO TO 200
END IF
IF (NTAB.GT.1) THEN
WRITE (MSGTXT,1000) NTAB, TABGLU(I)
CALL MSGWRT (6)
END IF
C Init table for read
VER = 1
CALL TABINI ('READ', TABGLU(I), DISKI(INUM), CNOI(INUM), VER,
* CATI(1,INUM), LUNIN, NKEY, NREC, NCOL, DATP, BUFFER, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('READ', 'TABINI', 'GLUTAB', IERR)
GO TO 999
END IF
C # rows in table
NROWS = BUFFER(5)
C For special cases get 2nd
C dimension of IF dependent arrays
DIMT(I) = 1
NKY = 1
IF (TABGLU(I).EQ.'AT') THEN
CALL TABKEY ('READ', 'NOPCAL ', NKY, BUFFER, KLOCS,
* KVALS, KTYP, IERR)
ELSE IF (TABGLU(I).EQ.'IM') THEN
CALL TABKEY ('READ', 'NPOLY ', NKY, BUFFER, KLOCS,
* KVALS, KTYP, IERR)
ELSE IF (TABGLU(I).EQ.'PC') THEN
CALL TABKEY ('READ', 'NO_TONES', NKY, BUFFER, KLOCS,
* KVALS, KTYP, IERR)
ELSE IF (TABGLU(I).EQ.'BP') THEN
CALL TABKEY ('READ', 'NO_CHAN ', NKY, BUFFER, KLOCS,
* KVALS, KTYP, IERR)
END IF
IF (IERR.GT.0) THEN
CALL TABERR ('READ', 'TABKEY', 'GLUTAB', IERR)
GO TO 999
END IF
IF ((KLOCS(1).GT.0).AND.(KTYP(1).EQ.4))
* DIMT(I) = KVALS(KLOCS(1))
IF (DIMT(I).EQ.0) DIMT(I) = 1
IF (DIMT(I).GT.1) TWOD = .TRUE.
C Find columns
CALL FNDCOL (COLKEY(I), TABIFS(1,I), UNIQUE(I), .TRUE.,
* BUFFER, LOGCOL(1,I), IERR)
C Find 2-D columns
IF (TWOD)
* CALL FNDCOL (TWOKEY(I), TWODIM(1,I), UNIQUE(I), .TRUE.,
* BUFFER, TWOCOL(1,I), IERR)
C Close to tidy up after FNDCOL
IDUM = 0
CALL TABIO ('CLOS', IDUM, NROWS, BUFFER, BUFFER, IERR)
C Reopen for read
VER = 1
CALL TABINI ('READ', TABGLU(I), DISKI(INUM), CNOI(INUM), VER,
* CATI(1,INUM), LUNIN, NKEY, NREC, NCOL, DATP, BUFFER, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('READ', 'TABINI', 'GLUTAB', IERR)
GO TO 999
END IF
C Open output table for write
C Update DATP array first
CALL FILL (256, 0, DATPO)
CALL COPY (128, DATP(129), DATPO(129))
DO 50 ICOL = 1, NCOL
IF (.NOT.WANKOL(ICOL, COLKEY(I), LOGCOL(1,I))) GO TO 50
LENGTH = DATPO(128+ICOL) / 10
RTYPE = DATPO(128+ICOL) - LENGTH * 10
LENGTH = LENGTH * NIFO / NIFI(INUM)
DATPO(128+ICOL) = RTYPE + LENGTH * 10
50 CONTINUE
C
VER = 1
NREC = 30
CALL TABINI ('WRIT', TABGLU(I), DISKO, CCNO, VER, CATBLK,
* LUNOUT, NKEY, NREC, NCOL, DATPO, BUFOUT, IERR)
IF (IERR.NE.-1) THEN
CALL TABERR ('WRIT', 'TABINI', 'GLUTAB', IERR)
GO TO 999
END IF
C Copy keyword/value pairs
CALL TABKEY ('ALL ', KEYWRD, NKEY, BUFFER, KLOCS, KVALS,
* KTYP, IERR)
IF (IERR.GT.0) THEN
CALL TABERR ('ALL ', 'TABKEY', 'GLUTAB', IERR)
GO TO 999
END IF
CALL TABKEY ('WRIT', KEYWRD, NKEY, BUFOUT, KLOCS, KVALS,
* KTYP, IERR)
IF (IERR.GT.0) THEN
CALL TABERR ('WRIT', 'TABKEY', 'GLUTAB', IERR)
GO TO 999
END IF
C Copy col labels
DO 70 ICOL = 1, NCOL
IDUM = 3
CALL TABIO ('READ', IDUM, ICOL, ITEMP, BUFFER, IERR)
CALL TABIO ('WRIT', IDUM, ICOL, ITEMP, BUFOUT, IERR)
IDUM = 4
CALL TABIO ('READ', IDUM, ICOL, ITEMP, BUFFER, IERR)
CALL TABIO ('WRIT', IDUM, ICOL, ITEMP, BUFOUT, IERR)
70 CONTINUE
C Update catalogue header
CALL CATIO ('UPDT', DISKO, CCNO, CATBLK, 'REST',
* BUFFI, IERR)
C Update IF keyword
CALL UPDKEY (BUFOUT, IFKEY(I), 4, NIFO, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('UPDT', 'UPDKEY', 'GLUTAB', IERR)
GO TO 999
END IF
C Now loop through the rows
C reading and enlarging IF
C dependent ones. Placing
C values from incoming table in
C the apropriate places in the
C outgoing table.
DO 150 IROW = 1, NROWS
IDUM = 0
CALL TABIO ('READ', IDUM, IROW, RECI, BUFFER, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('READ', 'TABIO ', 'GLUTAB', IERR)
GO TO 999
END IF
C Run through columns
DO 120 ICOL = 1, NCOL
C get type, length
LENGTH = DATP(128+ICOL) / 10
RTYPE = DATP(128+ICOL) - LENGTH * 10
IF (LENGTH.LE.0) GO TO 120
IPTR = DATP(ICOL)
OPTR = DATPO(ICOL)
C bad type
IF ((RTYPE.LT.1) .OR. (RTYPE.GT.7)) THEN
WRITE (MSGTXT,1010) TABGLU(I), IROW, ICOL, RTYPE
IERR = 5
GO TO 990
END IF
C Straight copy
IF (.NOT.WANKOL(ICOL, COLKEY(I), LOGCOL(1,I))) THEN
IF (RTYPE.EQ.1) CALL DPCOPY (LENGTH,
* RECDI(IPTR), RECDO(OPTR))
IF ((RTYPE.EQ.2) .OR. (RTYPE.EQ.3))
* CALL RCOPY (LENGTH, RECRI(IPTR), RECRO(OPTR))
IF (RTYPE.GE.4) CALL COPY (LENGTH, RECI(IPTR),
* RECO(OPTR))
C Reshuffle order
ELSE
TWOLEN = 1
IF (WANKOL(ICOL, COLKEY(I), TWOCOL(1,I)))
* TWOLEN = DIMT(I)
CALL LOADTB (FPASS, RTYPE, ORDER, NIFO, INUM,
* TWOLEN, RECI(IPTR), RECO(OPTR), RECRI(IPTR),
* RECRO(OPTR), RECDI(IPTR), RECDO(OPTR))
END IF
120 CONTINUE
C Write output record
IDUM = 0
CALL TABIO ('WRIT', IDUM, IROW, RECO, BUFOUT, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('WRIT', 'TABIO ', 'GLUTAB', IERR)
GO TO 999
END IF
150 CONTINUE
C Close 'em down
IDUM = 1
CALL TABIO ('CLOS', IDUM, NROWS, BUFFER, BUFFER, IERR)
CALL TABIO ('CLOS', IDUM, NROWS, BUFOUT, BUFOUT, IERR)
WRITE (MSGTXT,1020) TABGLU(I)
CALL MSGWRT (6)
200 CONTINUE
FPASS = .FALSE.
C Now we perform the glueing
C process on the tables. It is
C exactly analagous to that done
C in GLUDAT for the uv-data but,
C hopefully, easier.
DO 500 INUM = 2, NUMFIL
C Loop over the various tables
DO 450 I = 1, TABDO
CALL FNDEXT (TABGLU(I), CATBLK, NTAB)
IF (NTAB.EQ.0) GO TO 450
IF (TABGLU(I).EQ.'BL') GO TO 450
IF (NTAB.GT.1) THEN
WRITE (MSGTXT,1000) NTAB, TABGLU(I)
CALL MSGWRT (6)
END IF
INDTIM = -999.0
C Open the output table
C Read first to get various
C variables set
VER = 1
CALL TABINI ('READ', TABGLU(I), DISKO, CCNO, VER, CATBLK,
* LUNOUT, NKEY, NREC, NCOL, DATPO, BUFOUT, IERR)
IF (IERR.GT.0) THEN
CALL TABERR ('READ', 'TABINI', 'GLUTAB', IERR)
GO TO 999
END IF
C # rows in table
NROWS = BUFOUT(5)
C Find columns for row
C recognition, these are same
C for input & output tables.
CALL FNDCOL (IDKEY(I), IDKOLS(1,I), IDUNIQ(I), .TRUE.,
* BUFOUT, IDCOL, IERR)
IDUM = 1
CALL TABIO ('CLOS', IDUM, NROWS, BUFOUT, BUFOUT, IERR)
C then open for WRIT
CALL TABINI ('WRIT', TABGLU(I), DISKO, CCNO, VER, CATBLK,
* LUNOUT, NKEY, NREC, NCOL, DATPO, BUFOUT, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('WRIT', 'TABINI', 'GLUTAB', IERR)
GO TO 999
END IF
C Open input stream table
C for READ
VER = 1
CALL TABINI ('READ', TABGLU(I), DISKI(INUM), CNOI(INUM),
* VER, CATI(1,INUM), LUNIN, NKEY, NREC, NCOL, DATP, BUFFER,
* IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('READ', 'TABINI', 'GLUTAB', IERR)
GO TO 999
END IF
C # rows in input file
NROWIN = BUFFER(5)
C Philosophy is to read a row from
C the output table (the expanded
C one) and then find a match in
C the input stream table. Looking
C for the same source/antenna and
C time +/- 0.125 interval.
NROWCP = 0
KSTART = 1
DO 400 IROW = 1, NROWS
IDUM = 0
CALL TABIO ('READ', IDUM, IROW, RECO, BUFOUT, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('READ', 'TABIO ', 'GLUTAB', IERR)
GO TO 999
END IF
C Get variables
IF (TABGLU(I).NE.'SU') THEN
CALL GETVAR (DATPO, IDCOL, RECO, RECRO, RECDO,
* OTIME, OITIME, OSRC, OANT, OARR, OFQID)
EPS = 0.5D0 * OITIME
IF (OTIME.EQ.INDTIM) GO TO 350
ELSE IF (TABGLU(I).EQ.'SU') THEN
OSRC = RECO(DATPO(IDCOL(1)))
OTIME = 0.D0
OITIME = 0.0
OANT = 0
OARR = 0
OFQID = 0
END IF
C
C Loop through input table until
C find a row close in time to
C output table.
230 DO 250 KROW = KSTART, NROWIN
IDUM = 0
CALL TABIO ('READ', IDUM, KROW, RECI, BUFFER, IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('READ', 'TABIO ', 'GLUTAB', 6)
GO TO 999
END IF
C Get variables
IF (TABGLU(I).NE.'SU') THEN
CALL GETVAR (DATP, IDCOL, RECI, RECRI, RECDI,
* ITIME, IITIME, ISRC, IANT, IARR, IFQID)
ELSE IF (TABGLU(I).EQ.'SU') THEN
ISRC = RECI(DATP(IDCOL(1)))
ITIME = 0.D0
IITIME = 0.0
IANT = 0
IARR = 0
IFQID = 0
END IF
C Compare records
C Get new input record?
IF (TABGLU(I).NE.'SU') THEN
EQUTM = ITIME.EQ.OTIME
IF (.NOT.EQUTM) EQUTM = ((OTIME.LE.(ITIME+EPS))
* .AND.(OTIME.GE.(ITIME-EPS)))
EQUAN = IANT.EQ.OANT
EQUSU = ISRC.EQ.OSRC
EQUAR = IARR.EQ.OARR
EQUFQ = IFQID.EQ.OFQID
IF(EQUTM.AND.EQUAN.AND.EQUSU.AND.EQUAR.AND.EQUFQ)
* GO TO 350
ELSE IF (TABGLU(I).EQ.'SU') THEN
EQUSU = ISRC.EQ.OSRC
IF (EQUSU) GO TO 350
END IF
250 CONTINUE
GOTO 400
350 INDTIM = ITIME
INDEX(1) = IANT
INDEX(2) = ISRC
INDEX(3) = IARR
INDEX(4) = IFQID
INDEX(5) = KROW
NROWCP=NROWCP+1
C Compare variables in index
C with those from output table
IF ( INDEX(5) .LE. NROWIN ) THEN
IDUM = 0
CALL TABIO ('READ', IDUM, INDEX(5), RECI, BUFFER,
* IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('READ', 'TABIO ', 'GLUTAB', 7)
GO TO 999
END IF
C Run through columns
DO 360 ICOL = 1, NCOL
C get type, length
LENGTH = DATP(128+ICOL) / 10
RTYPE = DATP(128+ICOL) - LENGTH * 10
IF (LENGTH.LE.0) GO TO 360
IPTR = DATP(ICOL)
OPTR = DATPO(ICOL)
C bad type
IF ((RTYPE.LT.1) .OR. (RTYPE.GT.7)) THEN
WRITE (MSGTXT,1010) TABGLU(I), IROW, ICOL,
* RTYPE
IERR = 5
GO TO 990
END IF
C Fill empty slots
IF (WANKOL(ICOL, COLKEY(I), LOGCOL(1,I))) THEN
TWOLEN = 1
IF (WANKOL(ICOL, COLKEY(I), TWOCOL(1,I)))
* TWOLEN = DIMT(I)
CALL LOADTB (FPASS, RTYPE, ORDER, NIFO,
* INUM, TWOLEN, RECI(IPTR), RECO(OPTR),
* RECRI(IPTR),RECRO(OPTR), RECDI(IPTR),
* RECDO(OPTR))
END IF
360 CONTINUE
C Write the bonded record
IDUM = 0
CALL TABIO ('WRIT', IDUM, IROW, RECO, BUFOUT,
* IERR)
IF (IERR.NE.0) THEN
CALL TABERR ('WRIT', 'TABIO ', 'GLUTAB', IERR)
GO TO 999
END IF
C Go get next output record
GO TO 400
END IF
400 CONTINUE
C
C Close 'em down
C
IDUM = 1
CALL TABIO ('CLOS', IDUM, NROWS, BUFFER, BUFFER, IERR)
CALL TABIO ('CLOS', IDUM, NROWS, BUFOUT, BUFOUT, IERR)
C Test to see if most of the
C rows from the table attached
C to the second file are copied
C to the output table. If not
C delete, too dangerous to have
C around.
IF(NROWCP.LT.0.95*NROWIN) THEN
PERCOP = 100.0 * FLOAT(NROWCP)/FLOAT(NROWIN)
WRITE(MSGTXT,1030)
CALL MSGWRT (8)
WRITE(MSGTXT,1035) PERCOP, TABGLU(I)
CALL MSGWRT (8)
WRITE(MSGTXT,1040)
CALL MSGWRT (8)
WRITE(MSGTXT,1045)
CALL MSGWRT (8)
WRITE(MSGTXT,1050) TABGLU(I)
CALL MSGWRT (8)
WRITE(MSGTXT,1055)
CALL MSGWRT (8)
WRITE(MSGTXT,1060)
CALL MSGWRT (8)
* CALL DELEXT(TABGLU(I), DISKO, CCNO, 'WRWR',
* * BUFOUT, BUFFER, VER, IERR)
IF (IERR.NE.0) THEN
WRITE(MSGTXT,1065)
CALL MSGWRT (8)
END IF
END IF
450 CONTINUE
500 CONTINUE
GO TO 999
C
990 CALL MSGWRT (6)
C
999 RETURN
C-----------------------------------------------------------------------
1000 FORMAT ('GLUTAB: File 1 has ',I2,1X,A2,' tables, will only copy',
* ' first')
1010 FORMAT ('GLUTAB: TABLE ',A2,' ROW ',I6,' COL ',I2,' HAS ILLEGAL',
* ' TYPE ',I3)
1020 FORMAT (A2,' table copied and expanded to output file')
1030 FORMAT ('********** PROBLEM MERGING TABLES **********')
1035 FORMAT ('* Only ',F5.1,' percent of the 2nd ',A2,' table copied',
* ' to output table.')
1040 FORMAT ('* This probably means the times of the 2 input tables',
* ' are not')
1045 FORMAT ('* aligned.')
1050 FORMAT ('* DELETING OUTPUT ',A2,' TABLE!')
1055 FORMAT ('* Either fix input tables or remake output table.')
1060 FORMAT ('******************************************************')
1065 FORMAT ('GLUTAB: trouble deleting table.')
END
SUBROUTINE UPDKEY (BUFFER, KEYWRD, KEYTYP, KEYVAL, IERR)
C-----------------------------------------------------------------------
C Routine which updates a keyword-value pairs of an existing
C calibration table.
C Inputs:
C BUFFER I(*) Work buffer
C KEYWRD C*8 Keyword name
C KEYTYP I Keyword type
C KEYVAL I Keyword value
C Outputs:
C IERR I Error code, 0 => OK
C anything else => problem
C-----------------------------------------------------------------------
CHARACTER KEYWRD*8
INTEGER LOCS, KEYTYP, KEYNUM
INTEGER KEYVAL, BUFFER(*), IERR
C
INCLUDE 'INCS:DMSG.INC'
C-----------------------------------------------------------------------
C
LOCS = 1
KEYNUM = 1
C
CALL TABKEY ('WRIT', KEYWRD, KEYNUM, BUFFER, LOCS,
* KEYVAL, KEYTYP, IERR)
IF (IERR.NE.0) THEN
WRITE (MSGTXT,1000) IERR
GO TO 990
END IF
C
GO TO 999
C
990 CALL MSGWRT (6)
C
999 RETURN
C-----------------------------------------------------------------------
1000 FORMAT ('UPDKEY: ERROR ',I3,' UPDATING TABLE KEYWORDS')
END
LOGICAL FUNCTION WANKOL (ICOL, COLKEY, LOGCOL)
C-----------------------------------------------------------------------
C WANKOL determines whether a given column is in the list of those
C dependent on IF.
C Input:
C ICOL I Column number
C COLKEY I # in LOGCOL
C LOGCOL I(*) List of columns with IF dependency
C-----------------------------------------------------------------------
INTEGER ICOL, COLKEY, LOGCOL(*), I
C-----------------------------------------------------------------------
WANKOL = .FALSE.
DO 100 I = 1, COLKEY
IF (ICOL.EQ.LOGCOL(I)) THEN
WANKOL = .TRUE.
GO TO 999
END IF
100 CONTINUE
999 RETURN
END
SUBROUTINE LOADIF (FPASS, ORDER, NIFO, INFIL, IFLEN, BUFFIN,
* BUFOUT)
C-----------------------------------------------------------------------
C Routine that actually loads up the output buffer using the IF ORDER
C defined.
C Inputs:
C FPASS L If TRUE is the first pass through the data
C so must ensure that all unused space in
C BUFOUT is 0. If FALSE then it doesn't
C matter.
C ORDER I(*) Order of IFs
C NIFO I # IFs in output file
C INFIL I File number of input data stream
C BUFFIN R(*) Buffer containing input data stream
C IFLEN I The length of the data segement for a
C given IF.
C Outputs:
C BUFOUT R(*) Buffer containing output data stream
C-----------------------------------------------------------------------
INTEGER ORDER(*), NIFO, INFIL, IFLEN, I, J, INUM, START, STOP
REAL BUFFIN(*), BUFOUT(*)
LOGICAL FPASS
C-----------------------------------------------------------------------
IF (FPASS) THEN
I = NIFO * IFLEN
CALL RFILL (I, 0.0, BUFOUT)
END IF
DO 100 I = 1, NIFO
CALL GETORD (ORDER, I, INUM, J)
IF (INUM.NE.INFIL) GO TO 100
START = IFLEN * (J-1) + 1
STOP = IFLEN * (I-1) + 1
CALL RCOPY (IFLEN, BUFFIN(START), BUFOUT(STOP))
100 CONTINUE
RETURN
END
SUBROUTINE LOADTB (FPASS, RTYPE, ORDER, NIFO, INFIL, DIMTWO,
* BUFFI, BUFFIO, BUFFR, BUFFRO, BUFFD, BUFFDO)
C-----------------------------------------------------------------------
C Routine that loads up the output buffer using the IF ORDER
C defined. Version for binary tables tables.
C Inputs:
C FPASS L If TRUE is the first pass through the data
C so must ensure that all unused space in
C BUFFIO is 0. If FALSE then it doesn't
C matter.
C RTYPE I Data type, 1 = DP, 2 = SP, 4 = I
C ORDER I(*) Order of IFs
C NIFO I # IFs in output file
C INFIL I File number of input data stream
C BUFFI R(*) Buffer containing input data stream
C DIMTWO I Size of 2nd dimension (in # of RTYPE words),
C always is the most rapidly varying.
C Outputs:
C BUFFIO R(*) Buffer containing output data stream
C-----------------------------------------------------------------------
INTEGER RTYPE, ORDER(*), NIFO, INFIL, DIMTWO,
* I, J, INUM, START, STOP, BUFFI(*), BUFFIO(*)
REAL BUFFR(*), BUFFRO(*)
DOUBLE PRECISION BUFFD(*), BUFFDO(*)
LOGICAL FPASS
C-----------------------------------------------------------------------
IF (FPASS) THEN
I = NIFO * DIMTWO
IF (RTYPE.EQ.1) CALL DFILL (I, 0.D0, BUFFDO)
IF (RTYPE.EQ.2) CALL RFILL (I, 0.0, BUFFRO)
IF (RTYPE.EQ.4) CALL FILL (I, 0, BUFFIO)
END IF
DO 100 I = 1, NIFO
CALL GETORD (ORDER, I, INUM, J)
IF (INUM.NE.INFIL) GO TO 100
START = DIMTWO * (J-1) + 1
STOP = DIMTWO * (I-1) + 1
IF (RTYPE.EQ.1) CALL DPCOPY (DIMTWO, BUFFD(START),
* BUFFDO(STOP))
IF (RTYPE.EQ.2) CALL RCOPY (DIMTWO, BUFFR(START),
* BUFFRO(STOP))
IF (RTYPE.EQ.4) CALL COPY (DIMTWO, BUFFI(START),
* BUFFIO(STOP))
100 CONTINUE
RETURN
END
SUBROUTINE GETVAR (DATP, KOLS, RECI, RECR, RECD,
* TIME, TIMEI, SRC, ANT, ARR, FQID)
C-----------------------------------------------------------------------
C Routine which extracts the variables needed for table comparison from
C a given table record.
C Inputs:
C DATP I(256) Column pointers etc
C KOLS I(*) Columns to read
C RECI I(*) Integer record
C RECR R(*) Real record
C RECD D(*) Double precision record
C Outputs:
C TIME D Time of centre of record (days)
C TIMEI R Interval covered by record (days)
C SRC I Source number
C ANT I Antenna number
C ARR I Subarray number
C FQID I Freqid
C-----------------------------------------------------------------------
INTEGER DATP(256), KOLS(*), RECI(*), SRC, ANT, ARR, FQID
REAL RECR(*), TIMEI
DOUBLE PRECISION RECD(*), TIME
C
INTEGER IKOL, LENGTH, RTYPE, IPTR
C-----------------------------------------------------------------------
C Get time
IKOL = KOLS(1)
IPTR = DATP(IKOL)
LENGTH = DATP(128+IKOL) / 10
RTYPE = DATP(128+IKOL) - LENGTH * 10
IF (RTYPE.EQ.1) TIME = RECD(IPTR)
IF (RTYPE.EQ.2) TIME = RECR(IPTR)
C time interval
IKOL = KOLS(2)
IPTR = DATP(IKOL)
IF (IKOL.GT.0) THEN
LENGTH = DATP(128+IKOL) / 10
RTYPE = DATP(128+IKOL) - LENGTH * 10
IF (RTYPE.EQ.1) TIMEI = RECD(IPTR)
IF (RTYPE.EQ.2) TIMEI = RECR(IPTR)
ELSE
TIMEI = -1.0
END IF
C source id
IKOL = KOLS(3)
IPTR = DATP(IKOL)
IF (IKOL.GT.0) THEN
SRC = RECI(IPTR)
ELSE
SRC = -1
END IF
C antenna #
IKOL = KOLS(4)
IPTR = DATP(IKOL)
IF (IKOL.GT.0) THEN
ANT = RECI(IPTR)
ELSE
ANT = -1
END IF
C array #
IKOL = KOLS(5)
IPTR = DATP(IKOL)
IF (IKOL.GT.0) THEN
ARR = RECI(IPTR)
ELSE
ARR = -1
END IF
C freqid #
IKOL = KOLS(6)
IPTR = DATP(IKOL)
IF (IKOL.GT.0) THEN
FQID = RECI(IPTR)
ELSE
FQID = -1
END IF
C
RETURN
END
More information about the Daip
mailing list