LOCAL INCLUDE 'NEWHD.INC' INTEGER MLOCU, MLOCV, MLOCW, MLOCT, MLOCB, MLOCSU, MLOCFQ, * MLOCIT, MLOCID, MLOCA1, MLOCA2, MLOCSA COMMON /OUTHDR/ MLOCU, MLOCV, MLOCW, MLOCT, MLOCB, MLOCSU, MLOCFQ, * MLOCIT, MLOCID, MLOCA1, MLOCA2, MLOCSA LOCAL END LOCAL INCLUDE 'SPLAT.INC' C Local include for SPLAT INCLUDE 'INCS:ZPBUFSZ.INC' INCLUDE 'INCS:PUVD.INC' INTEGER SEQIN, CNOIN, SEQOUT, DISKIN, DISKO, NUMHIS, JBUFSZ, * LRECC, NRPRMC, LLOCWT, UQUAL, NOUTCH, NCHAVG, NINCH, ORIGCH, * CNTCHN(MAXIF), CHNSEL(3,20,MAXIF), PRMTRN(14), LLOCSU, CHINC, * IBUFF1(UVBFSS), IBUFF2(UVBFSS) HOLLERITH XNAMEI(3), XCLAIN(2), XXSOUR(4,30), XXCALC, XXSTOK, * XNAMOU(3), XCLAOU(2) CHARACTER NAMEIN*12, CLAIN*6, XSOUR(30)*16, XCALCO*4, XSTOK*4, * NAMEOU*12, CLAOUT*6, HISCRD(10)*64, UCALC*4 REAL XSIN, XDISIN, XQUAL, XTIME(8), XANTS(50), XBAND, XFREQ, * XFQID, XBIF, XEIF, XBCHAN, XECHAN, XSUBA, XDOCAL, XGUSE, * XDOPOL, XPDVER, XBLVER, XFLAG, XDOBND, XBPVER, XSMOTH(3), * XSOUT, XDISO, XDOUV, APARM(10), XCHNS(4,20), XCHANL, XCHINC, * XSOLIN, XBADD(10), BUFF1(UVBFSS), BUFF2(UVBFSS), BUFF3(UVBFSS), * SOLINT, REFCOR, AVGCH(MAXIF) LOGICAL OUTCOM, ASSEMB, DOIF, DOAVG, DOSUBS, INCOMP, OUTSOU EQUIVALENCE (IBUFF1, BUFF1), (IBUFF2, BUFF2) COMMON /BUFRS/ BUFF1, BUFF2, BUFF3, JBUFSZ COMMON /INPARM/ XNAMEI, XCLAIN, XSIN, XDISIN, XXSOUR, XQUAL, * XXCALC, XTIME, XXSTOK, XANTS, XBAND, XFREQ, XFQID, XBIF, XEIF, * XBCHAN, XECHAN, XSUBA, XDOCAL, XGUSE, XDOPOL, XPDVER, XBLVER, * XFLAG, XDOBND, XBPVER, XSMOTH, XNAMOU, XCLAOU, XSOUT, XDISO, * XDOUV, APARM, XCHNS, XCHANL, XCHINC, XSOLIN, XBADD COMMON /CHRCOM/ NAMEIN, CLAIN, XSOUR, XCALCO, XSTOK, NAMEOU, * CLAOUT, HISCRD, UCALC COMMON /MISC/ ORIGCH, SEQIN, SEQOUT, DISKIN, DISKO, CNOIN, NUMHIS, * LRECC, NRPRMC, LLOCWT, OUTCOM, UQUAL, DOIF, DOAVG, DOSUBS, * ASSEMB, SOLINT, INCOMP, CNTCHN, AVGCH, CHNSEL, REFCOR, PRMTRN, * OUTSOU, LLOCSU, NOUTCH, NCHAVG, NINCH, CHINC INCLUDE 'NEWHD.INC' LOCAL END PROGRAM SPLAT C----------------------------------------------------------------------- C! Applies calibration and split or assemble selected sources. C# UV Calibration C----------------------------------------------------------------------- C; Copyright (C) 1995-2017, 2019-2021 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@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 Splits a multisource uv data set into single-source data files. C Or: C Assembles selected sources into the new multi-source file. C Multiple sources may be processed in a single run. C Calibration and editing may be optionally applied. Fully C flagged data will not be copied. C Should also handle applying an SN table to a single source file. C Inputs: C AIPS adverb Description. C INNAME.....Input UV file name (name). Standard defaults. C INCLASS....Input UV file name (class). Standard defaults. C INSEQ......Input UV file name (seq. #). 0 => highest. C INDISK.....Disk drive # of input UV file. 0 => any. C SOURCES....Source list. C TIMERANG...Time range of the data to be copied. C STOKES.....Stokes type to pass. C BIF........First IF to copy. 0=>all. C EIF........Highest IF to copy. 0=>all higher than BIF C BCHAN......First channel to copy. 0=>all. C ECHAN......Highest channel to copy. 0=>all higher than BIF C SUBARRAY...Subarray number to copy. 0=>all. C DOCALIB....If true (>0) then calibrate the data. C GAINUSE....Version number of the Cal. table to use. C DOPOL......If >0 then do polarization calibration. C BLVER......The BL table to apply. C FLAGVER....Specifies the version of the flagging table. C DOBAND.....If true correct data for bandpass C BPVER......The BP table to apply C SMOOTH.....Smoothing function. C OUTCLASS...Output UV file name (class). Standard defaults. C The output file name will be the first 12 C characters of the name of the source. C OUTSEQ.....Output UV file name (seq. #). 0 => highest unique C OUTDISK....Disk drive # of output UV file. 0 => highest with C space for the file. C OUTCOMP....If > 1, compress output data. C APARM......Control information: C 1 = 1 => avg. freq. in IF C = 2 => avg IFs also C = 3 => avg each N channels C 2 = Integration time (sec) C 3 > 0 => drop subarray info C 4 > 0 => calibrate weights C 5 = 0 => pass only xc data C = 1 => pass xc/ac C = 2 => pass only ac C 6 > 0 => add full sourcename to header C 7 = 0 => assemble the sources C > 0 => split the sources C CHNSEL.....Channel selection C CHANNEL....Number of chans to average together C SOLINT.....Time of averaging in min. C BADDISK....Disks to avoid for scratch files. C----------------------------------------------------------------------- CHARACTER PRGM*6 INTEGER NUMSOU, IRET LOGICAL DOWANT INCLUDE 'INCS:DSEL.INC' INCLUDE 'SPLAT.INC' INTEGER SOCOUN(XSTBSZ), SULIST(XSTBSZ) INCLUDE 'INCS:DFIL.INC' INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:DUVH.INC' DATA PRGM /'SPLAT '/ C----------------------------------------------------------------------- C Get input parameters. CALL SPLTIN (PRGM, DOWANT, NUMSOU, SULIST, IRET) IF (IRET.NE.0) GO TO 990 C Loop over sources. CALL SPLTUV (DOWANT, NUMSOU, SULIST, SOCOUN, IRET) IF (IRET.NE.0) GO TO 990 C copy tables IF (ASSEMB) CALL COPTAB (SOCOUN, IRET) C Close down files, etc. 990 CALL DIE (IRET, BUFF1) C 999 STOP END SUBROUTINE SPLTIN (PRGN, DOWANT, NUMSOU, SULIST, IRET) C----------------------------------------------------------------------- C SPLTIN gets input parameters for SPLAT, finds input file and C prepares the list of sources. All selection criteria C except the source name is filled into the commons in D/CSEL.INC. C Inputs: PRGN C*6 Program name C Output: C DOWANT L If true sources listed are selected C NUMSOU I Number of sources to process, 0=>all C SULIST(*) I Source number list. C IRET I Error code: 0 => ok 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 See prologue comments in SPLAT for more details. C----------------------------------------------------------------------- HOLLERITH CATH(256) CHARACTER STAT*4, PRGN*6, UTYPE*2, TELTYP*8 INTEGER NUMSOU, SULIST(*), J, IRET LOGICAL DOWANT, HADSRC INTEGER NPARM, IROUND, IERR, I, LUN REAL CATR(256) LOGICAL MATCH INCLUDE 'SPLAT.INC' INCLUDE 'INCS:DSEL.INC' INCLUDE 'INCS:DFIL.INC' INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DUVH.INC' EQUIVALENCE (CATR, CATBLK, CATH) C----------------------------------------------------------------------- C Init for AIPS, disks, ... CALL ZDCHIN (.TRUE.) CALL VHDRIN CALL SELINI JBUFSZ = UVBFSS * 2 NUMHIS = 0 C Initialize /CFILES/ NSCR = 0 NCFILE = 0 IRET = 0 C Get input parameters. NPARM = 318 CALL GTPARM (PRGN, NPARM, RQUICK, XNAMEI, BUFF1, IERR) IF (IERR.EQ.0) GO TO 10 RQUICK = .TRUE. IRET = 8 IF (IERR.EQ.1) GO TO 999 WRITE (MSGTXT,1000) IERR CALL MSGWRT (8) C Restart AIPS 10 IF (RQUICK) CALL RELPOP (IRET, BUFF1, IERR) IF (IRET.NE.0) GO TO 999 IRET = 5 C Crunch input parameters. SEQIN = IROUND (XSIN) SEQOUT = IROUND (XSOUT) DISKIN = IROUND (XDISIN) DISKO = IROUND (XDISO) C Characters CALL H2CHR (12, 1, XNAMEI, NAMEIN) CALL H2CHR (12, 1, XNAMOU, NAMEOU) CALL H2CHR (6, 1, XCLAIN, CLAIN) CALL H2CHR (4, 1, XXCALC, XCALCO) CALL H2CHR (4, 1, XXSTOK, XSTOK) CALL H2CHR (6, 1, XCLAOU, CLAOUT) DO 20 I = 1,30 CALL H2CHR (16, 1, XXSOUR(1,I), XSOUR(I)) 20 CONTINUE DO 25 I = 1,50 ANTENS(I) = IROUND (XANTS(I)) 25 CONTINUE C Get CATBLK from old file. CNOIN = 1 UTYPE = 'UV' CALL CATDIR ('SRCH', DISKIN, CNOIN, NAMEIN, CLAIN, SEQIN, UTYPE, * NLUSER, STAT, BUFF1, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1040) IERR, NAMEIN, CLAIN, SEQIN, DISKIN, * NLUSER GO TO 990 END IF CALL CATIO ('READ', DISKIN, CNOIN, CATBLK, 'REST', BUFF1, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1060) IERR GO TO 990 END IF NCFILE = NCFILE + 1 FVOL(NCFILE) = DISKIN FCNO(NCFILE) = CNOIN FRW(NCFILE) = 0 C Find telescope name CALL H2CHR (8, 1, CATH(KHTEL), TELTYP) C Save input header CALL RCOPY (256, CATBLK, CATUV) C Get uv header info. CALL UVPGET (IRET) IF (IRET.NE.0) GO TO 999 C Input data compressed? INCOMP = CATBLK(KINAX).EQ.1 C Output data compressed> OUTCOM = XDOUV.GT.0.0 C If input data are compressed, C the output should be compressed C also IF (INCOMP) OUTCOM = .TRUE. C assemle or split? ASSEMB = APARM(7).EQ.0.0 BCHAN = IROUND (XBCHAN) BCHAN = MAX (1, MIN (BCHAN, CATBLK(KINAX+JLOCF))) ECHAN = IROUND (XECHAN) IF (ECHAN.LT.BCHAN) ECHAN = CATBLK(KINAX+JLOCF) ECHAN = MAX (1, MIN (ECHAN, CATBLK(KINAX+JLOCF))) IF (JLOCIF.GE.0) THEN BIF = IROUND (XBIF) BIF = MAX (1, MIN (BIF, CATBLK(KINAX+JLOCIF))) EIF = IROUND (XEIF) IF (BIF.GT.EIF) EIF = CATBLK(KINAX+JLOCIF) EIF = MAX (1, MIN (EIF, CATBLK(KINAX+JLOCIF))) ELSE BIF = 1 EIF = 1 END IF DOAVG = (APARM(1).GT.0.5) .AND. (APARM(1).LT.1.5) DOIF = (APARM(1).GT.1.5) .AND. (APARM(1).LT.2.5) DOSUBS = (APARM(1).GT.2.5) .AND. (APARM(1).LT.3.5) C Save the original number of C channels for later use. ORIGCH = CATBLK(KINAX+JLOCF) NINCH = ECHAN - BCHAN + 1 C calculate number of channels in C the output file NOUTCH = NINCH IF (DOAVG .OR. DOIF) NOUTCH = 1 C IF (DOSUBS) THEN NCHAVG = IROUND (XCHANL) NCHAVG = MAX (1, MIN (NCHAVG, NINCH)) CHINC = IROUND (XCHINC) CHINC = MIN (CHINC, NINCH) IF (CHINC.LE.0) CHINC = NCHAVG XCHANL = NCHAVG XCHINC = CHINC NOUTCH = (NINCH + CHINC - NCHAVG) / CHINC I = (NOUTCH-1) * CHINC + NCHAVG IF (I.LT.NINCH) THEN J = NINCH - I WRITE (MSGTXT,1080) J CALL MSGWRT (6) WRITE (MSGTXT,1100) CALL MSGWRT (6) ECHAN = BCHAN + I - 1 END IF WRITE (MSGTXT,1120) NOUTCH CALL MSGWRT (6) WRITE (MSGTXT,1130) NCHAVG CALL MSGWRT (5) WRITE (MSGTXT,1140) CHINC CALL MSGWRT (5) ELSE IF (DOAVG) THEN MSGTXT = 'Averaging all selected channels in frequency' CALL MSGWRT (5) END IF IF (DOIF) THEN MSGTXT = 'Averaging all selected channels in frequency' CALL MSGWRT (5) MSGTXT = 'Also averaging all selected IFs' CALL MSGWRT (5) END IF END IF C BADDISK DO 60 I = 1,10 IBAD(I) = IROUND (XBADD(I)) 60 CONTINUE C Time of averaging in days SOLINT = XSOLIN / (24.0 * 60.0) C Put selection criteria into C correct common. UNAME = NAMEIN UCLAS = CLAIN UDISK = DISKIN USEQ = SEQIN CALL CCOPY (30, XSOUR, SOURCS) CALL RCOPY (8, XTIME, TIMRNG) STOKES = XSTOK C DOCAL = XDOCAL.GT.0.0 DOPOL = IROUND (XDOPOL) IF ((DOPOL.EQ.0) .AND. (XDOPOL.GT.0.0)) DOPOL = 1 PDVER = IROUND (XPDVER) SUBARR = IROUND (XSUBA) FGVER = IROUND (XFLAG) CLVER = IROUND (XGUSE) CLUSE = IROUND (XGUSE) BLVER = IROUND (XBLVER) DOBAND = IROUND (XDOBND) BPVER = IROUND (XBPVER) DOWTCL = (XDOCAL.GT.0.0) .AND. (XDOCAL.LE.99.0) DOACOR = .FALSE. DOXCOR = .TRUE. IF (APARM(5).EQ.1) THEN DOACOR = .TRUE. DOXCOR = .TRUE. ELSE IF (APARM(5).EQ.2) THEN DOACOR = .TRUE. DOXCOR = .FALSE. END IF C Spectral smoothing CALL RCOPY (3, XSMOTH, SMOOTH) C DXTIME = APARM(2) / 86400.0 C Freq id IF (XBAND.GT.0.0) SELBAN = XBAND IF (XFREQ.GT.0.0) SELFRQ = XFREQ FRQSEL = IROUND (XFQID) IF (FRQSEL.EQ.0) FRQSEL = -1 LUN = 28 CALL FQMATC (DISKIN, CNOIN, CATBLK, LUN, SELBAN, SELFRQ, * MATCH, FRQSEL, IRET) IF (.NOT.MATCH) THEN MSGTXT = 'NO MATCH TO SELBAND/SELFREQ ADVERBS - CHECK INPUTS' IRET = 1 GO TO 990 END IF IF (IRET.GT.0) GO TO 999 SELQUA = IROUND (XQUAL) UQUAL = SELQUA SELQUA = MAX (-1, SELQUA) SELCOD = XCALCO UCALC = SELCOD C Kludge for SPLAT logic error C with multi-freqid data IF (((TELTYP.EQ.'ATCA') .OR. (TELTYP.EQ.'ATLBA')) .AND. * (FRQSEL.GT.0) .AND. (SELQUA.LE.0)) SELQUA = FRQSEL C Get source list IUDISK = FVOL(1) IUCNO = FCNO(1) IXLUN = 28 CALL SOUFIL (IRET) IF (IRET.NE.0) GO TO 999 DOWANT = DOSWNT NUMSOU = NSOUWD C CALL COPY (XSTBSZ, SOUWAN, SULIST) C Reset values in /SELCAL/ CALL CFILL (30, ' ', SOURCS) NSOUWD = 0 C Record whether there was C a positive source selection C before matching against FQSEL. HADSRC = (DOWANT) .AND. (NUMSOU.GT.0) C Remove sources not = FRQSEL CALL SOUNDX (FVOL(1), FCNO(1), DOWANT, NUMSOU, SULIST, IRET) DOSWNT = DOWANT C Check that a positive source C selection hasn't been C completely blown away. IF ((HADSRC) .AND. (NUMSOU.EQ.0)) THEN MSGTXT = 'REQUESTED SOURCES NOT FOUND: CHECK QUAL FREQID' IRET = 1 GO TO 990 END IF C GO TO 999 C 990 CALL MSGWRT (8) C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT ('SPLTIN: ERROR',I3,' OBTAINING INPUT PARAMETERS') 1040 FORMAT ('ERROR',I3,' FINDING ',A12,'.',A6,'.',I4,' DISK=', * I3,' USID=',I5) 1060 FORMAT ('ERROR',I3,' COPYING CATBLK ') 1080 FORMAT ('Will reject ',I3,' channels from the end of') 1100 FORMAT ('the input spectrum furthest from the LO') 1120 FORMAT ('Output file will have ',I4,' channels/IF') 1130 FORMAT ('Each',I3, ' channels will be averaged') 1140 FORMAT ('Every',I3, ' channels will be output') END SUBROUTINE SPLTUV (DOWANT, NUMSOU, SULIST, SOCOUN, IRET) C----------------------------------------------------------------------- C SPLTUV uses UVGET and SPLCOP to copy data into single source files, C or to assemble the selected sources into multiple source file C The history and relevant tables are also copied. C Input: C DOWANT L If true sources listed are selected C NUMSOU I Number of sources to process, 0=>all C SULIST(*) I Source number list. C Output: C SOCOUN(*) I Number of the given source occurances in the C data C IRET I Return code, 0 => OK, otherwise abort. C----------------------------------------------------------------------- INCLUDE 'INCS:PUVD.INC' CHARACTER NAME*12, VELTYP*8, VELDEF*8, CHVEL(4)*4 CHARACTER TEST*16, CHTM2*2 HOLLERITH CATH(256), CATUH(256), SNAME1(2),SNAME2(2) LOGICAL DOWANT, F, DOAPPT, FINISH, NOSUB, SMILE, SINGLE, TABLE, * EXIST, FITASC, ONZE, LOCAL, LOBL, UVOPEN, MSGDUN INTEGER NUMVIS, SOUCUR, MAXSOU, SLOOP, TOTREC(2,3), NUMSOU, * SULIST(*), IRET, INDEX, LRECU, NUMFRQ, IERR, K, K1, K2, IOFF, * SUKOLS(MAXSUC), SUNUMV(MAXSUC), SBUFF(768), I, SLUN, IDSOU, * INOGRP, TMPVER, SUB, LIMS1, LIMS2, SUBTMP, CATSAV(256), OUTDSK, * OUTCNO, ITEMP, SAVBND, IROUND, NCRPM, J, SUMCHN, SUFQID, * DPOSAV, NBASL, NC, NPRM, DUM, ERRCNT, INHIS REAL RPARM, VIS, CATR(256), OLDRP, CHWT DOUBLE PRECISION BANDW, RAEPO, DECEPO, EPOCH, RAAPP, DECAPP, * PMRA, PMDEC, CATD(128), OLDFRQ, RAOBS, DECOBS INCLUDE 'SPLAT.INC' INCLUDE 'INCS:DSEL.INC' INTEGER SOCOUN(*), NW(MAXIF), ISBAND(MAXIF), IIVER, CSUM, NNIF, * LUN, TBIF, TEIF, RNXRET, NSLIST, NSNAME(XSTBSZ), ONLIST, JTRIM DOUBLE PRECISION LSRVEL(MAXIF), FREQO(MAXIF), RESTFQ(MAXIF), * FOFF(MAXIF), FSUM, BWSUM CHARACTER SNMS(XSTBSZ)*16, TMPNAM*16, BNDCOD(MAXIF)*8 REAL FLUX(4,MAXIF), FINC(MAXIF) INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DUVH.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:DFIL.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DANS.INC' EQUIVALENCE (CATBLK, CATH, CATR, CATD), (CATUV, CATUH) SAVE ONZE, MSGDUN DATA CHVEL /'LSR ','BARY','HELI','RADI'/ DATA F /.FALSE./, ONZE, MSGDUN /2*.FALSE./ DATA LUN /18/ C----------------------------------------------------------------------- ERRCNT = 0 SMILE = F TMPVER = CLVER DOAPPT = DOAPPL NOSUB = APARM(3).GT.0.0 OLDRP = CATR(KRCRP+JLOCF) TBIF = BIF TEIF = EIF IF (DOSUBS) THEN CALL FILL (MAXIF, NCHAVG, CNTCHN) CHWT = BCHAN + (NCHAVG-1.0) / 2.0 CALL RFILL (MAXIF, CHWT, AVGCH) ELSE I = 60 * MAXIF CALL FILL (I, 0, CHNSEL) CALL FILL (MAXIF, 0, NW) DO 20 J = 1,20 K = IROUND (XCHNS(2,J)) IF (K.LE.0) GO TO 25 K = IROUND (XCHNS(4,J)) IF ((K.LE.0) .OR. (K.GT.MAXIF)) THEN K1 = 1 K2 = MAXIF ELSE K1 = K K2 = K END IF DO 15 K = K1,K2 NW(K) = NW(K) + 1 DO 10 I = 1,3 CHNSEL(I,NW(K),K) = IROUND (XCHNS(I,J)) IF (CHNSEL(I,NW(K),K).LT.0) CHNSEL(I,NW(K),K) = 0 10 CONTINUE IF (CHNSEL(3,NW(K),K).EQ.0) CHNSEL(3,NW(K),K) = 1 15 CONTINUE 20 CONTINUE C If no channel selection C use BCHAN - ECHAN 25 DO 50 K = 1,MAXIF IF (NW(K).LE.0) THEN NW(K) = 1 CHNSEL(1,1,K) = BCHAN CHNSEL(2,1,K) = ECHAN CHNSEL(3,1,K) = 1 END IF DO 30 I = 1,NW(K) CHNSEL(1,I,K) = MAX (BCHAN, MIN (CHNSEL(1,I,K), ECHAN)) IF (CHNSEL(2,I,K).LT.CHNSEL(1,I,K)) * CHNSEL(2,I,K) = ECHAN CHNSEL(2,I,K) = MAX (BCHAN, MIN (CHNSEL(2,I,K), ECHAN)) 30 CONTINUE C Find average channel number SUMCHN = 0 NC = 0 DO 40 I = BCHAN,ECHAN CHWT = 1.0 CALL WANTCH (CHNSEL(1,1,K), I, CHWT) IF (CHWT.GT.0.0) THEN SUMCHN = SUMCHN + I NC = NC + 1 END IF 40 CONTINUE IF (NC.GT.0) THEN AVGCH(K) = SUMCHN AVGCH(K) = AVGCH(K) / NC ELSE AVGCH(K) = 1.0 END IF CNTCHN(K) = NC 50 CONTINUE END IF C Get input reference freq. OLDFRQ = CATD(KDCRV+JLOCF) C Find number of subarrays IF (SUBARR.LE.0) THEN CALL FNDEXT ('AN', CATUV, LIMS2) LIMS1 = 1 LIMS2 = MAX (1, LIMS2) ELSE LIMS1 = SUBARR LIMS2 = SUBARR END IF SUBTMP = SUBARR DPOSAV = DOPOL SAVBND = DOBAND LOCAL = DOCAL LOBL = DOBL UVOPEN = .FALSE. C Add record about CQ table to C history file to document C delay decorrelation corrections SLUN = 27 CALL ISTAB ('CQ', FVOL(1), FCNO(1), 1, SLUN, SBUFF, TABLE, EXIST, * FITASC, IERR) IF (EXIST.AND.TABLE) THEN NUMHIS = NUMHIS + 1 HISCRD(NUMHIS) = 'CQ table present; (delay decorrelation)' END IF C Check if single source file SLUN = 27 CALL MULSDB (CATUV, SINGLE) IF (SINGLE) THEN CALL ISTAB ('SU', FVOL(1), FCNO(1), 1, SLUN, SBUFF, TABLE, * EXIST, FITASC, IERR) SINGLE = EXIST .AND. TABLE .AND. (IERR.EQ.0) END IF SINGLE = .NOT.SINGLE C not allow to assemble single C source file IF (SINGLE .AND. ASSEMB) THEN MSGTXT = 'Nothing to assemble because the data are ' // * 'single source' CALL MSGWRT (6) ASSEMB = .FALSE. END IF C Open source table IF ((.NOT.SINGLE) .AND. (.NOT.ASSEMB)) THEN CALL SOUINI ('READ', SBUFF, FVOL(1), FCNO(1), 1, CATUV, SLUN, * INOGRP, VELTYP, VELDEF, SUFQID, SOUCUR, SUKOLS, SUNUMV, * IRET) IF (IRET.NE.0) GO TO 999 MAXSOU = SBUFF(5) DO 90 SLOOP = 1,MAXSOU SOUCUR = SLOOP CALL TABSOU ('READ', SBUFF, SOUCUR, SUKOLS, SUNUMV, IDSOU, * SOURCS, SELQUA, SELCOD, FLUX, FREQO, BANDW, RAEPO, * DECEPO, EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, * RESTFQ, PMRA, PMDEC, IRET) IF (IRET.NE.0) GO TO 999 C See if this source wanted. IF (NUMSOU.GT.0) THEN DO 55 I = 1,NUMSOU IF (IDSOU.EQ.SULIST(I)) THEN IF (DOWANT) GO TO 60 GO TO 90 END IF 55 CONTINUE IF (DOWANT) GO TO 90 END IF 60 IF ((UQUAL.GE.0) .AND. (UQUAL.NE.SELQUA)) GO TO 90 IF (UCALC.NE.' ') THEN IF (UCALC.EQ.'*') THEN IF (SELCOD.EQ.' ') GO TO 90 ELSE IF (UCALC.EQ.'-CAL') THEN IF (SELCOD.NE.' ') GO TO 90 ELSE IF (SELCOD.NE.UCALC) GO TO 90 END IF END IF DO 70 I = 1,NSLIST IF (SOURCS(1).EQ.SNMS(I)) THEN NSNAME(I) = NSNAME(I)+1 GO TO 90 END IF 70 CONTINUE NSLIST = NSLIST + 1 NSNAME(NSLIST) = 1 SNMS(NSLIST) = SOURCS(1) 90 CONTINUE C Setup for single source case: ELSE IRET = 0 MAXSOU = 1 NUMSOU = 0 CALL CFILL (30, ' ', SOURCS) END IF C restore SOURCS for the source C selection in UVGET IF (ASSEMB) THEN CALL CCOPY (30, XSOUR, SOURCS) MAXSOU = 1 END IF C C Loop here over sources INHIS = NUMHIS DO 700 SLOOP = 1,MAXSOU IF (.NOT.ASSEMB) THEN SOUCUR = SLOOP NUMHIS = INHIS C Read source table IF (.NOT.SINGLE) THEN CALL TABSOU ('READ', SBUFF, SOUCUR, SUKOLS, SUNUMV, * IDSOU, SOURCS, SELQUA, SELCOD, FLUX, FREQO, BANDW, * RAEPO, DECEPO, EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, * LSRVEL, RESTFQ, PMRA, PMDEC, IRET) IF (IRET.NE.0) GO TO 999 C See if this source wanted. IF (NUMSOU.GT.0) THEN DO 120 I = 1,NUMSOU IF (IDSOU.EQ.SULIST(I)) THEN IF (DOWANT) GO TO 130 GO TO 700 END IF 120 CONTINUE IF (DOWANT) GO TO 700 END IF 130 IF ((UQUAL.GE.0) .AND. (UQUAL.NE.SELQUA)) GO TO 700 IF (UCALC.NE.' ') THEN IF (UCALC.EQ.'*') THEN IF (SELCOD.EQ.' ') GO TO 700 ELSE IF (UCALC.EQ.'-CAL') THEN IF (SELCOD.NE.' ') GO TO 700 ELSE IF (SELCOD.NE.UCALC) GO TO 700 END IF END IF IF ((SELCOD.EQ.' ') .AND. (.NOT.ASSEMB)) SELCOD = '-CAL' END IF END IF ONLIST = 1 IF (.NOT.ASSEMB) THEN DO 135 I = 1,NSLIST IF (SOURCS(1).EQ.SNMS(I)) ONLIST = NSNAME(I) 135 CONTINUE END IF C Create header, fiddle tables etc C off cal adverbs to sum subarrays SUBARR = SUBTMP DOPOL = -1 DOBAND = 0 DOCAL = .FALSE. DOBL = .FALSE. MSGSUP = 31000 CALL UVGET ('INIT', RPARM, VIS, IERR) MSGSUP = 0 UVOPEN = .TRUE. C If a UV GET ERROR IF (IERR.NE.0) THEN IF (IERR.EQ.2) THEN MSGTXT = 'UVGET ERROR, CHECK THAT REQUESTED GAIN '// * 'TABLE EXISTS' CALL MSGWRT(5) END IF C Jump to try next source GO TO 650 C End if UVGET Error END IF C Close again - only need header C for sum of subarrays. CALL UVGET ('CLOS', RPARM, VIS, IERR) IF (IERR.NE.0) GO TO 650 DOPOL = DPOSAV DOBAND = SAVBND DOCAL = LOCAL DOBL = LOBL UVOPEN = F DOAPPL = F CLVER = CLUSE C do what DGHEAD would have done C Warn if processing X-Y data C without poln. calibrating. C to Stokes Q U or V IF ((DOPOL.LE.0) .AND. (CATBLK(KICPD).LE.0) .AND. * (CATD(KDCRV+JLOCS)+CATR(KRCIC+JLOCS)*(CATBLK(KINAX+JLOCS)-1) * .GT.1.5D0)) THEN MSGTXT = 'WARNING: uncalibrated polarization data' // * ' may be a problem' IF (.NOT.MSGDUN) CALL MSGWRT (6) MSGDUN = .TRUE. END IF IF ((DOPOL.GT.0) .AND. (CATBLK(KICPD).GT.0)) THEN MSGTXT = 'WARNING: polarization calibration being applied' * // ' more than once' IF (.NOT.MSGDUN) CALL MSGWRT (6) MSGDUN = .TRUE. END IF IF (DOPOL.GT.0) CATBLK(KICPD) = CATBLK(KICPD) + 1 IF (DOCAL) CATBLK(KICCL) = CATBLK(KICCL) + 1 IF (DOBAND.GT.0) CATBLK(KICBP) = CATBLK(KICBP) + 1 C Put new values in CATBLK. CALL MAKOUT (NAMEIN, CLAIN, SEQIN, ' ', NAME, CLAOUT, * SEQOUT) CALL CHR2H (6, CLAOUT, KHIMCO, CATH(KHIMC)) C name of the output aips data IF ((ASSEMB) .OR. (SINGLE)) THEN C store inname in outname IF (NAMEOU.EQ.' ') THEN CALL CHR2H (12, NAME, KHIMNO, CATH(KHIMN)) C store the given name in catalog ELSE CALL CHR2H (12, NAMEOU, KHIMNO, CATH(KHIMN)) END IF C sources are splitted ELSE C Name after source. IF (NAMEOU.EQ.' ') THEN TMPNAM = SOURCS(1) IF (ONLIST.GT.1) THEN I = JTRIM (SELCOD) WRITE (TMPNAM(9:),1130) SELQUA IF (I.GT.0) TMPNAM(9:8+I) = SELCOD(:I) END IF CALL CHR2H (12, TMPNAM, KHIMNO, CATH(KHIMN)) C use OUTNAME ELSE CALL CHR2H (12, NAMEOU, KHIMNO, CATH(KHIMN)) IF (SLOOP.GT.1) SEQOUT = 0 END IF END IF CATBLK(KIIMS) = SEQOUT C Velocity etc. info IF=BIF C Do it only for multiple source C file; otherwise keep the C original values in header IF (.NOT.SINGLE) THEN CATD(KDRST) = RESTFQ(BIF) CATD(KDARV) = LSRVEL(BIF) C CRP already corr for bchan CATR(KRARP) = CATR(KRCRP+JLOCF) C Velocity reference frame ITEMP = 3 IF (VELTYP(1:4).EQ.CHVEL(1)) ITEMP = 1 IF (VELTYP(1:4).EQ.CHVEL(2)) ITEMP = 2 IF (VELTYP(1:4).EQ.CHVEL(3)) ITEMP = 2 IF (VELDEF(1:4).EQ.CHVEL(4)) ITEMP = ITEMP + 256 CATBLK(KIALT) = ITEMP C UVGET corrects for BCHAN ELSE CATR(KRARP) = CATR(KRARP) END IF C Update CATBLK if Averaging with C use output freq pixel as ref. C C If averaging set CATBLK REFCOR = 0 IF (DOIF) THEN IIVER = 1 CALL CHNDAT ('READ', BUFF1, IUDISK, IUCNO, IIVER, CATUV, * LUN, NNIF, FOFF, ISBAND, FINC, BNDCOD, FRQSEL, IRET) IF (IRET.NE.0) GO TO 999 FSUM = 0.0D0 BWSUM = 0.0D0 CSUM = 0 DO 160 I = TBIF,TEIF FSUM = FSUM + (FOFF(I) - FOFF(TBIF) + * (AVGCH(I) - OLDRP) * FINC(I)) * CNTCHN(I) BWSUM = BWSUM + CNTCHN(I) * FINC(I) CSUM = CSUM + CNTCHN(I) 160 CONTINUE FSUM = FSUM / CSUM CATD(KDCRV+JLOCF) = CATD(KDCRV+JLOCF) + FSUM CATR(KRCRP+JLOCF) = 1.0 CATR(KRCIC+JLOCF) = BWSUM CATBLK(KINAX+JLOCF) = 1 CATBLK(KINAX+JLOCIF) = 1 C No velocity info if averaging. CATD(KDRST) = 0.0 CATD(KDARV) = 0.0 CATR(KRARP) = 0.0 C averaging spectral channels ELSE IF (DOAVG .OR. DOSUBS) THEN C correction of freq REFCOR = AVGCH(1) - OLDRP CATD(KDCRV+JLOCF) = CATD(KDCRV+JLOCF) + REFCOR * * CATR(KRCIC+JLOCF) CATR(KRCRP+JLOCF) = 1.0 C No velocity info if averaging. CATD(KDRST) = 0.0 CATD(KDARV) = 0.0 CATR(KRARP) = 0.0 IF (DOSUBS) THEN CATR(KRCIC+JLOCF) = CATR(KRCIC+JLOCF) * CHINC ELSE CATR(KRCIC+JLOCF) = CATR(KRCIC+JLOCF) * CNTCHN(1) END IF CATBLK(KINAX+JLOCF) = NOUTCH END IF C Make sure there is data IF (CATBLK(KIGCN).LE.0) GO TO 650 C remove REMOVEDs CALL PRMSET (CATBLK, PRMTRN) NPRM = CATBLK(KIPCN) C force source if ASSEMB CALL AXEFND (8, 'SOURCE ', NPRM, CATH(KHPTP), IOFF, I) OUTSOU = (ASSEMB) .AND. ((IOFF.LT.0) .OR. (I.GT.0)) IF (OUTSOU) THEN LLOCSU = NPRM INDEX = KHPTP + 2 * LLOCSU CALL CHR2H (8, 'SOURCE ', 1, CATH(INDEX)) CATBLK(KIPCN) = CATBLK(KIPCN) + 1 END IF IF (OUTCOM) THEN LLOCWT = NPRM IF (OUTSOU) LLOCWT = LLOCWT + 1 INDEX = KHPTP + 2 * LLOCWT CALL CHR2H (8, 'WEIGHT ', 1, CATH(INDEX)) CALL CHR2H (8, 'SCALE ', 1, CATH(INDEX+2)) CATBLK(KINAX) = 1 CATBLK(KIPCN) = CATBLK(KIPCN) + 2 END IF CCNO = 1 CALL UVCREA (DISKO, CCNO, BUFF1, IERR) IF (IERR.NE.0) THEN IF ((.NOT.SINGLE) .AND. (SELQUA.EQ.-1)) THEN IF (IERR.NE.2) THEN WRITE (MSGTXT,1040) IERR CALL MSGWRT (6) END IF GO TO 660 ELSE IF (IERR.EQ.2) THEN MSGTXT = 'CANNOT OVERWRITE OLD FILE' CALL MSGWRT (6) END IF GO TO 650 END IF END IF C actual output file CALL UVPGET (IERR) MLOCU = ILOCU MLOCV = ILOCV MLOCW = ILOCW MLOCT = ILOCT MLOCB = ILOCB MLOCSU = ILOCSU MLOCFQ = ILOCFQ MLOCIT = ILOCIT MLOCID = ILOCID MLOCA1 = ILOCA1 MLOCA2 = ILOCA2 MLOCSA = ILOCSA LRECU = LREC NCRPM = NRPARM IF (.NOT.OUTSOU) LLOCSU = ILOCSU C Report gain table version, once IF ((DOCAL) .AND. (.NOT.ONZE)) THEN IF (SINGLE) THEN IF (CLVER.LE.0) CALL FNDEXT ('SN', CATUV, CLVER) WRITE (MSGTXT,1060) 'SN', CLVER ELSE IF (CLVER.LE.0) CALL FNDEXT ('CL', CATUV, CLVER) WRITE (MSGTXT,1060) 'CL', CLVER END IF CALL MSGWRT(3) ONZE = .TRUE. END IF NCFILE = NCFILE + 1 FVOL(NCFILE) = DISKO FCNO(NCFILE) = CCNO FRW(NCFILE) = 2 OUTDSK = DISKO OUTCNO = CCNO C copy keywords CALL KEYCOP (DISKIN, CNOIN, DISKO, CCNO, IERR) C make an index table CALL RNXGET (DISKIN, CNOIN, CATUV) CALL RNXINI (DISKO, CCNO, CATBLK, RNXRET) C Loop over subarrays. NUMVIS = 0 NUMFRQ = ECHAN - BCHAN + 1 DO 640 SUB = LIMS1,LIMS2 C Read AN table to find the C number of antennas to evaluate C the number of baseline CALL GETANT (DISKIN, CNOIN, SUB, CATUV, BUFF1, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1080) IERR, SUB CALL MSGWRT (8) GO TO 999 END IF C cross correlation only NBASL = NSTNS * (NSTNS - 1) / 2 C cros + auto IF (APARM(5).EQ.1) THEN NBASL = NSTNS * (NSTNS + 1) / 2 C auto only ELSE IF (APARM(5).EQ.2) THEN NBASL = NSTNS END IF C SUBARR = SUB C Save CATBLK - UVGET will modify CALL COPY (256, CATBLK, CATSAV) C Initialize reading data CALL UVGET ('INIT', RPARM, VIS, IERR) IF (IERR.GT.0) GO TO 645 C handle missing subarray IF ((IERR.LT.0) .AND. (SUB.LT.LIMS2)) THEN MSGSUP = 32000 CALL UVGET ('CLOS', RPARM, VIS, IERR) MSGSUP = 0 CALL COPY (256, CATSAV, CATBLK) GO TO 640 END IF UVOPEN = .TRUE. C Update sort order if necessary IF (NUMVIS.GT.0) CALL CHR2H (2, '**', 1, CATSAV(KITYP)) C Restore CATBLK CALL COPY (256, CATSAV, CATBLK) C Copy data FINISH = SUB.EQ.LIMS2 CALL SPLCOP (NUMVIS, TOTREC, FINISH, DOAVG, DOIF, DOSUBS, * DISKO, CCNO, NCHAVG, CHINC, NOUTCH, SOLINT, NOSUB, BUFF1, * JBUFSZ, FREQO, OLDFRQ, NBASL, NUMHIS, HISCRD, * CHNSEL, OUTCOM, LLOCWT, OUTSOU, LLOCSU, BUFF2, BUFF3, * LRECU, NCRPM,NPRM, PRMTRN, AVGCH, CNTCHN, OLDRP, SOCOUN, * RNXRET, IERR) IF (IERR.NE.0) GO TO 645 SMILE = .TRUE. UVOPEN = F NUMVIS = NUMVIS + NVIS 640 CONTINUE C Add full sourcename IF (APARM(6).GT.0.0) THEN CALL CHR2H (8, SOURCS(1)(1:8), 1, SNAME1) CALL CHR2H (8, SOURCS(1)(9:16), 1, SNAME2) CALL H2CHR (8, 1, SNAME1, TEST(1:8)) CALL H2CHR (8, 1, SNAME2, TEST(9:16)) CALL CATKEY ('WRIT', OUTDSK, OUTCNO, 'SOURNAM1', 1, 1, * SNAME1, 3, BUFF1, IERR) CALL CATKEY ('WRIT', OUTDSK, OUTCNO, 'SOURNAM2', 1, 1, * SNAME2, 3, BUFF1, IERR) END IF C History CLVER = TMPVER DOAPPL = DOAPPT SUBARR = SUBTMP C close NX table CALL RNXCLS (RNXRET) IF (RNXRET.NE.0) THEN MSGTXT = 'OUTPUT NX TABLE, IF ANY, IS INCOMPLETE' CALL MSGWRT (6) ELSE MSGTXT = 'New NX table written' CALL MSGWRT (2) END IF C EXIST = SINGLE .OR. ASSEMB CALL SPLTHI (OUTDSK, OUTCNO, EXIST, IDSOU) CLVER = CLUSE DOAPPL = F NCFILE = NCFILE - 2 GO TO 700 C error after UVCREA 645 DUM = 0 CHTM2 = 'UV' CALL RNXCLS (RNXRET) IF (UVOPEN) THEN MSGSUP = 32000 CALL UVGET ('CLOS', RPARM, VIS, I) MSGSUP = 0 END IF UVOPEN = F CALL CATDIR ('CSTA', OUTDSK, OUTCNO, NAME, CLAOUT, DUM, CHTM2, * DUM, 'CLWR', BUFF1, I) CALL MDESTR (OUTDSK, OUTCNO, CATBLK, BUFF1, J, I) FVOL(NCFILE) = 0 FCNO(NCFILE) = 0 FRW(NCFILE) = 0 NCFILE = NCFILE - 1 C Error, close input file C then resume. C Tell which source 650 IF ((CATBLK(KIGCN).LE.0) .OR. (IERR.EQ.-1)) THEN MSGTXT = '** NO VISIBILITIES FOUND FOR ''' // SOURCS(1) // * '''' ELSE MSGTXT = '** PROBLEM WITH SOURCE ''' // SOURCS(1) // * '''' END IF CALL MSGWRT (6) WRITE (MSGTXT,1650) SELCOD, SELQUA CALL MSGWRT (6) ERRCNT = ERRCNT + 1 660 IF (UVOPEN) THEN MSGSUP = 32000 CALL UVGET ('CLOS', RPARM, VIS, IERR) MSGSUP = 0 END IF UVOPEN = F C restore cal flags! DOPOL = DPOSAV DOBAND = SAVBND DOCAL = LOCAL DOBL = LOBL 700 CONTINUE C Make sure bad files C destroyed IRET = 1 IF (SMILE) IRET = 0 IF (IRET.NE.0) THEN MSGTXT = 'FAILED TO SELECT VALID DATA' CALL MSGWRT (9) END IF C Close source table IF ((.NOT.SINGLE) .AND. (.NOT.ASSEMB)) * CALL TABIO ('CLOS', 1, SOUCUR, SBUFF, SBUFF, IERR) NCFILE = NCFILE - 1 GO TO 999 C 999 RETURN C----------------------------------------------------------------------- 1040 FORMAT ('ERROR',I5,' CREATING OUTPUT UV FILE') 1060 FORMAT ('Applying ',A,' Table version ',I5) 1080 FORMAT ('ERROR',I3,' READING AN TABLE; SUB =', I3) 1130 FORMAT (I4.4) 1650 FORMAT ('** CALCODE ''',A,''' QUALIFIER',I5) END SUBROUTINE SPLTHI (DISK, CNO, SINGLE, IDSOU) C----------------------------------------------------------------------- C SPLTHI copies and updates history file. It also copies any tables C extension files. C Input: C DISK I Output file disk number C CNO I Output file catalog slot number. C SINGLE L F => write an output FO table C IDSOU I Restrict FO to this source number C----------------------------------------------------------------------- INTEGER DISK, CNO, IDSOU LOGICAL SINGLE C CHARACTER NOTTYP(26)*2, NAMOUT*12, HILINE*72, LABEL*8, UTYPE*2 HOLLERITH CATH(256) INTEGER IERR, I, LUN1, LUN2, NONOT, J, SUBA, K, NSUB, IVER, ISOU REAL CATR(256) DOUBLE PRECISION CATD(128), FQOFF LOGICAL T, TABLE, EXIST, FITASC INCLUDE 'SPLAT.INC' INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DFIL.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:DSEL.INC' INCLUDE 'INCS:DUVH.INC' INCLUDE 'INCS:DANT.INC' EQUIVALENCE (CATBLK, CATH, CATR, CATD) DATA LUN1, LUN2 /28,29/ DATA T /.TRUE./ C COPTAB tables DATA NONOT, NOTTYP /26, 'BP', 'CL', 'CD', 'CP', 'CQ', 'FG', 'GC', * 'IM', 'MC', 'PC', 'PD', 'SN', 'SY', 'SU', 'TY', 'WX', 'BL', C done elsewhere in SPLAT * 'NX', 'AN', 'FQ', 'PO', C bad idea to copy/obsolete * 'CC', 'CH', 'AT', 'VT', 'HF'/ C----------------------------------------------------------------------- C Write History. CALL HIINIT (3) C Copy/open history file. CALL HISCOP (LUN1, LUN2, DISKIN, DISK, CNOIN, CNO, CATBLK, BUFF1, * BUFF2, IERR) IF (IERR.LE.2) GO TO 10 WRITE (MSGTXT,1000) IERR CALL MSGWRT (6) GO TO 200 C New history 10 CALL HENCO1 (TSKNAM, NAMEIN, CLAIN, SEQIN, DISKIN, LUN2, BUFF2, * IERR) IF (IERR.NE.0) GO TO 200 CALL H2CHR (12, KHIMNO, CATH(KHIMN), NAMOUT) CALL HENCOO (TSKNAM, NAMOUT, CLAOUT, CATBLK(KIIMS), DISKO, LUN2, * BUFF2, IERR) IF (IERR.NE.0) GO TO 200 C calibration HI CALL HISCAL (APARM(7), LUN2, IBUFF2, IERR) IF (IERR.NE.0) GO TO 200 C Compressed data IF (OUTCOM) THEN WRITE (HILINE,1160) TSKNAM CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF C Calibration C split or assemble IF (APARM(7).EQ.0.0) THEN WRITE (HILINE,1200) TSKNAM, APARM(7) CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF IF (APARM(7).GT.0.0) THEN WRITE (HILINE,1220) TSKNAM, APARM(7) CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF C Averaging IF (DOAVG) THEN WRITE (HILINE,1240) TSKNAM, APARM(1) CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF IF (DOIF) THEN WRITE (HILINE,1260) TSKNAM, APARM(1) CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF IF (DOSUBS) THEN WRITE (HILINE,1280) TSKNAM, APARM(1), NCHAVG, CHINC CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF C Channel selection IF ((DOAVG) .OR. (DOIF)) THEN DO 65 K = BIF,EIF DO 60 I = 1,10 IF ((CHNSEL(1,I,K).GT.0) .AND. * (CHNSEL(2,I,K).GT.CHNSEL(1,I,K))) THEN WRITE (HILINE,1140) TSKNAM, (CHNSEL(J,I,K), J=1,3), K CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF 60 CONTINUE 65 CONTINUE END IF C average time IF (SOLINT.GT.0.0) THEN WRITE (HILINE,1300) TSKNAM, XSOLIN CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF C Integration time IF (APARM(2).GT.0.0) THEN WRITE (HILINE,1320) TSKNAM, APARM(2) CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 END IF C Add any other history IF (NUMHIS.GT.0) THEN WRITE (LABEL,1460) TSKNAM DO 150 I = 1,NUMHIS HILINE = LABEL // HISCRD(I) CALL HIADD (LUN2, HILINE, BUFF2, IERR) IF (IERR.NE.0) GO TO 200 150 CONTINUE END IF NUMHIS = 0 C Close HI file 200 CALL HICLOS (LUN2, T, BUFF2, IERR) C Copy tables CALL ALLTAB (NONOT, NOTTYP, LUN1, LUN2, DISKIN, DISK, CNOIN, CNO, * CATBLK, BUFF1, BUFF2, IERR) C copy PO table CALL FNDEXT ('PO', CATUV, IVER) IF (IVER.GT.0) THEN ISOU = IDSOU IF (SINGLE) ISOU = 0 CALL POSEL (DISKIN, CNOIN, DISK, CNO, IVER, CATUV, CATBLK, * LUN1, LUN2, ISOU, BUFF1, BUFF2, IERR) END IF C make FO table IF (.NOT.SINGLE) THEN IF (CLVER.LE.0) CALL FNDEXT ('CL', CATUV, CLVER) CALL CL2FO (DISKIN, CNOIN, CLVER, LUN1, CATUV, DISK, CNO, * LUN2, CATBLK, IDSOU, BUFF1, BUFF2, IERR) END IF C CALL FNDEXT ('AN', CATUV, NSUB) C Get freq from AN table SUBA = 1 CALL GETANT (DISKIN, CNOIN, SUBA, CATUV, BUFF1, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1480) IERR CALL MSGWRT (8) GO TO 999 END IF C CALL UVPGET (IERR) IF (IERR.NE.0) GO TO 999 FQOFF = FREQ - SAFREQ IF (FQOFF.NE.0.0D0) THEN MSGTXT = 'Updating FREQ in AN tables' CALL MSGWRT (3) END IF IF (DOPOL.GT.0) THEN MSGTXT = 'Resetting pol cal values in output AN tables' CALL MSGWRT (3) END IF C Reference frequency in AN table C IF selection DO 300 SUBA = 1,NSUB CALL ISTAB ('AN', DISKIN, CNOIN, SUBA, LUN1, BUFF1, TABLE, * EXIST, FITASC, IERR) IF ((EXIST) .AND. (IERR.EQ.0)) THEN CALL ANSEL (DISKIN, CNOIN, DISK, CNO, SUBA, SUBA, CATUV, * CATBLK, LUN1, LUN2, BIF, EIF, FQOFF, DOPOL, IBUFF1, * IBUFF2, IERR) IF (IERR.GT.0) GO TO 999 END IF 300 CONTINUE C Update CATBLK. CALL CATIO ('UPDT', DISK, CNO, CATBLK, 'REST', BUFF1, IERR) IF (IERR.NE.0) GO TO 999 C Clear status UTYPE = 'UV' CALL CATDIR ('CSTA', DISK, CNO, NAMOUT, CLAOUT, CATBLK(KIIMS), * UTYPE, NLUSER, 'CLWR', BUFF1, IERR) IF (IERR.NE.0) GO TO 999 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT ('SPLTHI: ERROR',I3,' COPY/OPEN HISTORY FILE') 1140 FORMAT (A6,'Avgd: Start, Stop, Inc ',2I5,I3,' IF=',I3) 1160 FORMAT (A6,'Output data in compressed format') 1200 FORMAT (A6,'APARM(7) =',F5.2, ' / => assemble selected sources') 1220 FORMAT (A6,'APARM(7) =',F5.2, ' / => split selected sources') 1240 FORMAT (A6,'APARM(1) =',F5.2,' / => average in freq.') 1260 FORMAT (A6,'APARM(1) =',F5.2,' / => average IFs and channels') 1280 FORMAT (A6,'APARM(1) =',F5.2,' / => average ',I2,' increment', * I2,' channels') 1300 FORMAT (A6,'SOLINT =',F7.3,'min / => averaged in time') 1320 FORMAT (A6,'APARM(2) =',F5.2,' / Integration time (sec)') 1460 FORMAT (A6,' /') 1480 FORMAT ('SPLTHI: ERROR',I3,' READING OUTPUT AN TABLE') END SUBROUTINE HISCAL (ASSEMB, LUN, HBUFF, IRET) C----------------------------------------------------------------------- C Adds information about calibration to open HI file C Inputs: C LUN I Logical unit number of HI file C In/Out: C HBUFF I(256) HI buffer in use C Inputs in common: DSEL.INC C Output: C IRET I Return code, 0=>OK C----------------------------------------------------------------------- REAL ASSEMB INTEGER LUN, HBUFF(256), IRET C INTEGER I1, I2, I, ITRIM, J1, J2, ISCAL CHARACTER HILINE*72, SOUCOD(2)*7 INCLUDE 'INCS:DSEL.INC' INCLUDE 'INCS:DMSG.INC' DATA SOUCOD /'SOURCES', 'CALSOUR'/ C----------------------------------------------------------------------- C Add selection criteria: C Sources C All cal sources ? IF (ASSEMB.GT.0.0) GO TO 25 IF (NSOUWD.LE.0) THEN WRITE (HILINE,2000) TSKNAM, SOUCOD(1) CALL HIADD (LUN, HILINE, HBUFF, IRET) ELSE ISCAL = 2 DO 10 I = 1,30 IF (SOURCS(I).NE.CALSOU(I)) ISCAL = 1 10 CONTINUE C Included or excluded? WRITE (HILINE,2001) TSKNAM, SOUCOD(ISCAL), NSOUWD IF (DOSWNT) WRITE (HILINE,2002) TSKNAM, SOUCOD(ISCAL), NSOUWD CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C 1st 2 and label. I1 = 1 IF (SOURCS(1)(1:1).EQ.'-') I1 = 2 I2 = 1 IF (SOURCS(2)(1:1).EQ.'-') I2 = 2 WRITE (HILINE,2003) TSKNAM, SOUCOD(ISCAL), SOURCS(1)(I1:), * SOURCS(2)(I2:) CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Rest of sources DO 20 I = 3,MIN(NSOUWD,30),2 IF (SOURCS(I).NE.' ' .OR. SOURCS(I+1).NE.' ') THEN I1 = 1 IF (SOURCS(I)(1:1).EQ.'-') I1 = 2 J1 = ITRIM (SOURCS(I)) I2 = 1 IF (SOURCS(I+1)(1:1).EQ.'-') I2 = 2 J2 = ITRIM (SOURCS(I+1)) WRITE (HILINE,2004) TSKNAM, SOURCS(I)(I1:J1), * SOURCS(I+1)(I2:J2) CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 END IF 20 CONTINUE END IF C QUAL, CALCODE 25 WRITE (HILINE,2020) TSKNAM, SELQUA, SELCOD CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C TIMERANG CALL HITIME (TSTART, TEND, LUN, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Stokes' WRITE (HILINE,2021) TSKNAM, STOKES CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C IF range WRITE (HILINE,2022) TSKNAM, BIF, EIF CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Chan range WRITE (HILINE,2023) TSKNAM, BCHAN, ECHAN CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Subarray WRITE (HILINE,2024) TSKNAM, SUBARR CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Flag table IF (DOFLAG) THEN WRITE (HILINE,2030) TSKNAM, FGVER ELSE HILINE = TSKNAM // '/ no flagging applied' END IF CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Calibration info IF (DOCAL) THEN WRITE (HILINE,2035) TSKNAM, CLUSE ELSE HILINE = TSKNAM // '/ no continuum calibration applied' END IF CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Calibrate weights? IF (DOWTCL) THEN HILINE = TSKNAM // '/ Weights calibrated' ELSE HILINE = TSKNAM // '/ Weights not calibrated' END IF CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 C Polzn correction IF (DOPOL.GT.0) THEN WRITE (HILINE,2036) TSKNAM, DOPOL CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 WRITE (HILINE,2041) TSKNAM, PDVER IF (PDVER.GT.0) CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 END IF C BL table IF (DOBL) THEN WRITE (HILINE,2037) TSKNAM, BLVER CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 END IF C BP table IF (DOBAND.GT.0.0) THEN WRITE (HILINE,2038) TSKNAM, DOBAND CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 WRITE (HILINE,2039) TSKNAM, BPVER CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 END IF C Spectral smoothing IF (SMOOTH(1).GT.0.5) THEN I1 = SMOOTH(1) + 0.5 I2 = SMOOTH(3) + 0.5 WRITE (HILINE,2040) TSKNAM, I1, SMOOTH(2), I2 CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 END IF C Frequency selection IF (FRQSEL.GT.0) THEN WRITE (HILINE,2045) TSKNAM, FRQSEL CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 END IF C uv range IF ((UVRNG(1).GT.0.0) .OR. (UVRNG(2).LT.1.E10)) THEN WRITE (HILINE,2050) TSKNAM, UVRNG CALL HIADD (LUN, HILINE, HBUFF, IRET) IF (IRET.NE.0) GO TO 999 END IF C 999 RETURN C----------------------------------------------------------------------- 2000 FORMAT (A6,A7,' = '''' /All sources selected') 2001 FORMAT (A6,'N_',A7,'=',I5,' /Following Sources excluded:') 2002 FORMAT (A6,'N_',A7,'=',I5,' /Following Sources included:') 2003 FORMAT (A6,A7,' = ''',A,''',''',A,'''') 2004 FORMAT (A6,' ,''',A,''',''',A,'''') 2020 FORMAT (A6,'QUAL =',I5,' CALCODE = ',A4) 2021 FORMAT (A6,'STOKES = ''',A4,''' / Stokes type') 2022 FORMAT (A6,'BIF =',I4,', EIF =',I4,'/ IF range') 2023 FORMAT (A6,'BCHAN =',I4,', ECHAN =',I4,'/ Chan range') 2024 FORMAT (A6,'SUBARRAY =',I4) 2030 FORMAT (A6,'FLAGVER =',I5,' /Flagging table used') 2035 FORMAT (A6,'GAINUSE =',I5,' /CL table used') 2036 FORMAT (A6,'DOPOL = ',I2,', polarization correction made') 2037 FORMAT (A6,'BLVER=',I3,' / BL table # applied to data') 2038 FORMAT (A6,'DOBAND = ',I2,' / Type of BP correction done') 2039 FORMAT (A6,'BPVER=',I3,' / BP correction used BP table #') 2040 FORMAT (A6,'SMOOTH = ',I1,',',F6.1,',',I4, * ' / Spectral smoothing parms') 2041 FORMAT (A6,'PDVER=',I3,' / DOPOL correction used PD table #') 2045 FORMAT (A6,'FRQSEL =',I5,' / FREQID selected') 2050 FORMAT (A6,'UVRANGE =',1PE11.4,' ,',1PE11.4, * ' / uv range kilolambda') END SUBROUTINE SPLCOP (VISOFF, TOTREC, FINISH, DOAVG, DOIF, DOSUBS, * DISK, CNO, NCHAVG, CHINC, NOUTCH, SOLINT, NOSUB, BUFF1, JBUFSZ, * FREQO, OLDFRQ, NBASL, NUMHIS, HISCRD, CHNSEL, OUTCOM, * LLOCWT, OUTSOU, LLOCSU, BUFF2, BUFF3, LRECU, NCRPM, NPRM, * PRMTRN, AVGCH, CNTCHN, OLDRP,SOCOUN, RNXRET, IRET) C----------------------------------------------------------------------- C SPLCOP reads and split/assemble data files with optional averaging C over the frequency and time axes. C Input: C VISOFF I Offset in output file C TOTREC I(2,3) Total counts of record flagging C FINISH L If True, finish the source, compress, etc. C DOAVG L If true, average frequencies in IF C DOIF L If true, average across IF's also C DISK I Output disk number. C CNO I Output catalog slot number. C NOSUB L IF True drop subarray code. C JBUFSZ I Size of BUFF1 C FREQO D(*) IF Frequency offsets for source (Hz) C OLDFRQ D Reference freq. of input data. C CHNSEL I(3,10) Start, stop and incr channel number to average C OUTCOM L If TRUE write compressed data C LLOCWT I Offset of compressed weight r.p in output data C OUTSOU l Add source number to random parms C LLOCSU I Where to add it C LRECU I length of output vis record C Input from common: C INCF I Increment in freq. of data from UVGET C INCIF I Increment in IF of data from UVGET C INCS I Increment in Stokes' of data from UVGET C JLOCF I Offset of freq. of data from UVGET C JLOCIF I Offset of IF of data from UVGET C JLOCS I Offset of Stokes' of data from UVGET C Output: C NUMHIS I Number of history entries C HISCR C*64 History entries C BUFF1 R(*) Output I/O buffer. C BUFF2 R(*) Buffer for compressed data C SOCOUN I(*) Number of the given source occurances in the C data C RNXRET I NX table error code in/out C IRET I Return error code, 0=>OK, otherwise error. C----------------------------------------------------------------------- INCLUDE 'INCS:DSEL.INC' INTEGER VISOFF, TOTREC(2,3), DISK, CNO, NCHAVG, CHINC, NOUTCH, * JBUFSZ, NBASL, NUMHIS, CHNSEL(3,20,*), LLOCWT, LLOCSU, LRECU, * NCRPM, CNTCHN(*), SOCOUN(*), IRET, PRMTRN(*), NPRM, RNXRET LOGICAL FINISH, DOAVG, NOSUB, DOIF, OUTCOM, OUTSOU REAL SOLINT, BUFF1(*), BUFF2(*), BUFF3(*), AVGCH(*), OLDRP DOUBLE PRECISION FREQO(MAXIF), OLDFRQ CHARACTER HISCRD(*)*64 C HOLLERITH CATH(256) CHARACTER NAME*48, TELTYP*4, OUTRAN(20)*8, BNDCOD(MAXIF)*8 LOGICAL T, F, DOFSCL, DOSUBS, EOF DOUBLE PRECISION FDIFF, CATD(128), FOFF(MAXIF), FOFF1, FREQO1 INTEGER LUN, FIND, BIND, LENBU, NIO, JNCIF, JNCS, NCOPY, J, * NUMFRQ, NNIF, NOPOL, NCORR, BO, I, XCOUNT, BLCODE, IIVER, * FREQID, JNCF, TBIF, TEIF, MXIF, ANOTA(20), NWORDS, JTRIM, * ISBAND(MAXIF), ISB(MAXIF), NPR, NPD, RNXSOR LONGINT IPD, IPR REAL VIS(MAXCIF*3), FRSCL, CATR(256), FINC(MAXIF), DTUTC, * RBUFF(2), DBUFF(2), RPARM(20), FRPARM(20), FINCIN INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:DUVH.INC' INCLUDE 'INCS:DANS.INC' EQUIVALENCE (CATBLK, CATR, CATD, CATH) SAVE ANOTA DATA T, F /.TRUE.,.FALSE./ DATA LUN, BO /18,1/ DATA MXIF /MAXIF/ C----------------------------------------------------------------------- C Get sideband info IIVER = 1 CALL CHNDAT ('READ', BUFF1, IUDISK, IUCNO, IIVER, CATUV, LUN, * NNIF, FOFF, ISBAND, FINC, BNDCOD, FRQSEL, IRET) CALL H2CHR (4, 1, CATH(KHTEL), TELTYP) DO 10 I = 1,MXIF IF ((FINC(I).LT.0.0) .OR. (TELTYP.EQ.'ATCA')) THEN ISB(I) = -1 ELSE ISB(I) = 0 END IF 10 CONTINUE C Set lengths of input axes. NUMFRQ = ECHAN - BCHAN + 1 NUMIF = 1 IF (JLOCIF.GT.0) NUMIF = EIF - BIF + 1 TBIF = BIF TEIF = EIF NOPOL = CATBLK(KINAX+JLOCS) C Check number of frequencies. IF ((NUMFRQ.GT.MAXCHA) .OR. (NUMIF.GT.MAXIF) .OR. * (NOPOL*NUMIF*NUMFRQ.GT.MAXCIF)) THEN IRET = 1 MSGTXT = 'SPLCOP: VISIBILITIES TOO BIG FOR BUFFERS' GO TO 990 END IF C Set uvw freq. scaling FRSCL = CATD(KDCRV+JLOCF) / (OLDFRQ + 1.0D-15) DOFSCL = ABS (FRSCL-1.0).GT.1.0E-6 C Set output increments C (averaging) IF (DOSUBS) THEN JNCIF = INCIF IF (JLOCF.LT.JLOCIF) JNCIF = INCIF / CHINC JNCS = INCS IF (JLOCF.LT.JLOCS) JNCS = INCS / CHINC JNCF = INCF ELSE IF (DOAVG .OR. DOIF) THEN JNCIF = INCIF IF (JLOCF.LT.JLOCIF) JNCIF = INCIF / NUMFRQ JNCS = INCS IF (JLOCF.LT.JLOCS) JNCS = INCS / NUMFRQ JNCF = INCF ELSE JNCIF = INCIF JNCS = INCS JNCF = INCF END IF END IF C If output file already open C close it. IF (FIND.GT.0) THEN IF ((FTAB(FIND).EQ.LUN) .AND. (VISOFF.LE.0)) * CALL ZCLOSE (LUN, FIND, IRET) END IF C Setup for new file IF (VISOFF.LE.0) THEN C Zero flag counts TOTREC(1,1) = 0 TOTREC(2,1) = 0 TOTREC(1,2) = 0 TOTREC(2,2) = 0 TOTREC(1,3) = 0 TOTREC(2,3) = 0 C Set output file name. CALL ZPHFIL ('UV', DISK, CNO, 1, NAME, IRET) C Open output file. CALL ZOPEN (LUN, FIND, DISK, NAME, T, F, T, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1000) IRET GO TO 990 END IF C Init vis file for write LENBU = 1 NCORR = (LRECU - NCRPM) / CATBLK(KINAX) NCOPY = 3 * NCORR CALL UVINIT ('WRIT', LUN, FIND, CATBLK(KIGCN), VISOFF, LRECU, * LENBU, JBUFSZ, BUFF2, BO, BIND, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 END IF END IF C initialize number of occurance C of the sources in the data CALL FILL (XSTBSZ, 0, SOCOUN) XCOUNT = 0 DO 100 I = 1,NVIS+1 C Average in freq in each IF CALL UVGET ('READ', RPARM, VIS, IRET) EOF = IRET.LT.0 IF (EOF) THEN IF (SOLINT.GT.0.0) GO TO 80 GO TO 110 END IF IF (IRET.NE.0) GO TO 999 C Average spectral chunks IF (DOSUBS) THEN CALL AVGSUB (VIS, NOPOL, NUMIF, NCHAVG, CHINC, NOUTCH, JNCS, * JNCIF, JNCF, ISB, BUFF1) C Average in IF and freq. ELSE IF (DOIF) THEN CALL AVGCIF (VIS, NOPOL, BCHAN, ECHAN, TBIF, TEIF, CHNSEL, * JNCS, BUFF1) C Average with channel selection ELSE IF (DOAVG) THEN CALL AVGCHN (VIS, NOPOL, BCHAN, ECHAN, TBIF, TEIF, CHNSEL, * JNCS, JNCIF, BUFF1) C plain copy ELSE CALL RCOPY (NCOPY, VIS, BUFF1) END IF IF (ILOCSU.GT.-1) THEN CURSOU = RPARM(1+ILOCSU) + 0.1 C Too many sources IF (CURSOU.GT.XSTBSZ) THEN IRET = 9 WRITE (MSGTXT,1060) GO TO 990 ELSE SOCOUN(CURSOU) = SOCOUN(CURSOU) + 1 END IF ELSE IF (OUTSOU) THEN CURSOU = SOUWAN(1) SOCOUN(CURSOU) = SOCOUN(CURSOU) + 1 END IF C Drop subarray if requested IF (NOSUB) THEN IF (ILOCB.GE.0) THEN BLCODE = RPARM(1+ILOCB) RPARM(1+ILOCB) = BLCODE ELSE RPARM(1+ILOCSA) = 1.0 END IF END IF C Frequency scale uvw IF (DOFSCL) THEN RPARM(1+ILOCU) = RPARM(1+ILOCU) * FRSCL RPARM(1+ILOCV) = RPARM(1+ILOCV) * FRSCL RPARM(1+ILOCW) = RPARM(1+ILOCW) * FRSCL END IF C restructure RPARM DO 20 J = 1,NPRM FRPARM(J) = RPARM(PRMTRN(J)) 20 CONTINUE C averaging 80 IF (SOLINT.GT.0.0) THEN IF (I.EQ.1) THEN J = NRPARM NRPARM = NCRPM CALL LISRAN (OUTRAN, ANOTA) NRPARM = J NPD = 3 * NOUTCH * NUMIF * NOPOL NWORDS = (NPD * NBASL - 1) / 1024 + 1 CALL ZMEMRY ('GET ', 'AVGTIM', NWORDS, DBUFF, IPD, IRET) IF (IRET.EQ.0) THEN NPR = NCRPM + 2 NWORDS = (NPR * NBASL - 1) / 1024 + 1 CALL ZMEMRY ('GET ', 'AVGTIM', NWORDS, RBUFF, IPR, * IRET) END IF IF (IRET.NE.0) THEN MSGTXT = 'FAILED TO GET DYNAMIC MEMORY FOR AVERAGING' GO TO 990 END IF END IF C data time -UTC in days DTUTC = ANTIAT / 86400.0 C time average CALL AVGTIM (SOLINT, NOUTCH, NUMIF, NOPOL, XCOUNT, FRPARM, * BUFF1, BUFF2, BUFF3, NBASL, OUTCOM, LLOCWT, OUTSOU, * LLOCSU, SOUWAN(1), NCRPM, JNCIF, JNCS, JNCF, NCORR, BIND, * I, LUN, EOF, DTUTC, FIND, ANOTA, NPR, RBUFF(1+IPR), NPD, * DBUFF(1+IPD), RNXRET, IRET) IF (EOF) GO TO 110 IF (IRET.NE.0) THEN WRITE (MSGTXT,1160) IRET GO TO 990 END IF C Write new without time ave. ELSE NIO = 1 XCOUNT = XCOUNT + 1 CALL RCOPY (NCRPM, FRPARM, BUFF2(BIND)) RNXSOR = 1 IF (OUTSOU) THEN BUFF2(BIND+LLOCSU) = SOUWAN(1) RNXSOR = SOUWAN(1) END IF C update NX table CALL RNXUPD (BUFF2(BIND), RNXSOR, RNXRET) IF (OUTCOM) THEN CALL ZUVPAK (NCORR, BUFF1, BUFF2(BIND+LLOCWT), * BUFF2(BIND+NCRPM)) ELSE CALL RCOPY (NCOPY, BUFF1, BUFF2(BIND+NCRPM)) END IF CALL UVDISK ('WRIT', LUN, FIND, BUFF2, NIO, BIND, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1160) IRET GO TO 990 END IF END IF 100 CONTINUE C If FINISH shut down output 110 IF (XCOUNT.LE.0) THEN WRITE (MSGTXT,1110) NVIS CALL MSGWRT (6) J = JTRIM (SOURCS(1)) WRITE (MSGTXT,1111) SOURCS(1)(:J), SELCOD, SELQUA CALL MSGWRT (6) WRITE (MSGTXT,1112) SUBARR CALL MSGWRT (6) END IF NVIS = XCOUNT C Sum flag counts TOTREC(1,1) = TOTREC(1,1) + CNTREC(1,1) TOTREC(2,1) = TOTREC(2,1) + CNTREC(2,1) TOTREC(1,2) = TOTREC(1,2) + CNTREC(1,2) TOTREC(2,2) = TOTREC(2,2) + CNTREC(2,2) TOTREC(1,3) = TOTREC(1,3) + CNTREC(1,3) TOTREC(2,3) = TOTREC(2,3) + CNTREC(2,3) C Flush output IF (.NOT.FINISH) GO TO 800 NIO = 0 CALL UVDISK ('FLSH', LUN, FIND, BUFF2, NIO, BIND, IRET) IF (IRET.EQ.0) GO TO 120 WRITE (MSGTXT,1160) IRET GO TO 990 C Compress output file. 120 NVIS = XCOUNT + VISOFF CALL UCMPRS (NVIS, DISK, CNO, LUN, CATBLK, IRET) C Put vis. count in CATBLK CATBLK(KIGCN) = NVIS C Update CATBLK. CALL CATIO ('UPDT', DISK, CNO, CATBLK, 'REST', BUFF1, IRET) IF (IRET.EQ.0) GO TO 140 WRITE (MSGTXT,1180) IRET C Copy relevant portion of IF C table. 140 IF (JLOCIF.GT.0) THEN C Read old IIVER = 1 CALL CHNDAT ('READ', BUFF1, IUDISK, IUCNO, IIVER, CATUV, * LUN, NNIF, FOFF, ISBAND, FINC, BNDCOD, FRQSEL, IRET) IF (IRET.NE.0) GO TO 999 C Fixup IF (DOIF) THEN NNIF = 1 FOFF(1) = 0.0D0 FINC(1) = CATR(KRCIC+JLOCF) TBIF = 1 ELSE IF (DOAVG) THEN DO 145 I = TBIF,TEIF FOFF(I) = FOFF(I) + (AVGCH(I)-OLDRP)*FINC(I) 145 CONTINUE END IF FDIFF = CATD(KDCRV+JLOCF) - OLDFRQ NNIF = TEIF - TBIF + 1 FOFF1 = FOFF(TBIF) FREQO1 = FREQO(TBIF) FINCIN = FINC(TBIF) DO 150 I = TBIF,TEIF IF (DOSUBS) THEN FOFF(I) = FOFF(I) + (FINC(I) - FINCIN) * * (AVGCH(TBIF) - OLDRP) FINC(I) = FINC(I) * CHINC ELSE IF (DOAVG) THEN FINC(I) = FINC(I) * CNTCHN(I) END IF C force the first IF to zero FOFF(I) = FOFF(I) - FOFF1 + FREQO(I) - FREQO1 150 CONTINUE END IF C Output ref IF = 1 CATD(KDCRV+JLOCIF) = 1.0D0 CATR(KRCRP+JLOCIF) = 1.0 C Rewrite new IIVER = 1 FREQID = 1 CALL CHNDAT ('WRIT', BUFF1, DISK, CNO, IIVER, CATBLK, LUN, * NNIF, FOFF(TBIF), ISBAND(TBIF), FINC(TBIF), BNDCOD(TBIF), * FREQID, IRET) IF (IRET.NE.0) GO TO 999 END IF C Give data summary and history IF (DOCAL) THEN WRITE (MSGTXT,1200) CALL MSGWRT (6) WRITE (HISCRD(NUMHIS+1),1200) NUMHIS = NUMHIS + 1 WRITE (MSGTXT,1220) TOTREC(1,1), TOTREC(1,2), TOTREC(1,3) CALL MSGWRT (6) WRITE (HISCRD(NUMHIS+1),1220) TOTREC(1,1), TOTREC(1,2), * TOTREC(1,3) NUMHIS = NUMHIS + 1 WRITE (MSGTXT,1240) TOTREC(2,1), TOTREC(2,2), TOTREC(2,3) CALL MSGWRT (6) WRITE (HISCRD(NUMHIS+1),1240) TOTREC(2,1), TOTREC(2,2), * TOTREC(2,3) NUMHIS = NUMHIS + 1 ELSE WRITE (MSGTXT,1260) NVIS IF (OUTCOM) WRITE (MSGTXT,1280) NVIS CALL MSGWRT (6) WRITE (HISCRD(NUMHIS+1),1260) NVIS NUMHIS = NUMHIS + 1 END IF IF (NVIS.GT.0) GO TO 700 C No data found. IRET = 9 MSGTXT = 'SPLCOP: ERROR - NO DATA WRITTEN' GO TO 990 C Close files 700 CALL ZCLOSE (LUN, FIND, IRET) 800 CALL UVGET ('CLOS', BUFF1(BIND), BUFF1(BIND+NRPARM), IRET) GO TO 999 C Error 990 CALL MSGWRT (8) C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT ('SPLCOP: ERROR',I5,' OPENING OUTPUT FILE') 1020 FORMAT ('SPLCOP: ERROR',I5,' INIT. OUTPUT FILE') 1060 FORMAT ('SPLCOP: TOO MANY SOURCES IN THE DATA') 1110 FORMAT ('SPLCOP FOUND NO SAMPLES OUT OF',I8,' POSSIBLE') 1111 FORMAT (' SOURCE, CALCODE, QUAL= ''',A,''' ''',A,'''',I5) 1112 FORMAT (' IS SUBARRAY',I3,' IN CL/SN TABLE?') 1160 FORMAT ('SPLCOP: ERROR',I5,' WRITING OUTPUT FILE') 1180 FORMAT ('SPLCOP: ERROR',I3,' UPDATING CATALOGUE HEADER') 1200 FORMAT (10X,' Previously flagged ',' flagged by gain ', * ' kept') 1220 FORMAT ('Partially ',2(I15,5X),I10) 1240 FORMAT ('Fully ',2(I15,5X),I10) 1260 FORMAT (I9,' Visibilities written') 1280 FORMAT (I9,' Compressed visibilities written') END SUBROUTINE UPDKEY (BUFFER, KEYWRD, KEYTYP, KEYVAL, IERR) C----------------------------------------------------------------------- C Routine which updates a keyword-value pairs of an existing C table. C Inputs: C BUFFER I(*) Work buffer C KEYWRD C*8 Keyword name C KEYTYP I Keyword type C KEYVAL D Keyword value C Outputs: C IERR I Error code, 0 => OK C anything else => problem C----------------------------------------------------------------------- CHARACTER KEYWRD*8 INTEGER LOCS, KEYTYP, KEYNUM INTEGER BUFFER(*), IERR DOUBLE PRECISION KEYVAL 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 CL KEYWORDS') END SUBROUTINE COPTAB (SOCOUN, IRET) C----------------------------------------------------------------------- C Updates tables for selection by IF C Input: C SOCOUN(*) I Number of the given source occurances in the data C Inputs in common: C BIF I First IF C EIF I Highest IF selected C FQOFF D Frequency offset C SELIF L Select IFs or not C CNTCHN I Number of averaged frequency channels C Output: C IRET I Return code, 0=>OK C----------------------------------------------------------------------- INTEGER IRET C DOUBLE PRECISION TB, TE, CATD(128) INTEGER IERR, LUN1, LUN2, VER, NVER, OFQID, ISUB, JSUB, NA, * AN(50), I, SOCOUN(*), LEIF, BPOL, EPOL, IROUND, BVER LOGICAL TABLE, EXIST, FITASC REAL CATR(256), TEMP INCLUDE 'SPLAT.INC' INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DUVH.INC' INCLUDE 'INCS:DFIL.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:DSEL.INC' INCLUDE 'INCS:PFLG.INC' INCLUDE 'INCS:DFLG.INC' EQUIVALENCE (CATBLK, CATD, CATR) DATA LUN1, LUN2 /28,29/ C----------------------------------------------------------------------- IF (DOFLAG) THEN IFLUN = 30 CALL FLGINI ('READ', FGBUFF, IUDISK, IUCNO, FGVER, CATUV, * IFLUN, IFGRNO, FGKOLS, FGNUMV, IERR) IF (IERR.NE.0) DOFLAG = .FALSE. END IF C TSTART start of data in days C TEND end of data in days C TSTART, TEND is outout of C UVGET('INIT'..) C TB, TE should be DOUBLE PR. C for ...SEL routines TB = TSTART TE = TEND LEIF = EIF IF (DOIF) LEIF = BIF NA = 0 DO 20 I = 1,50 AN(I) = 0 20 CONTINUE MSGTXT = 'Updating tables for IF/FREQID/channel selection' CALL MSGWRT (4) C IF (SUBARR.GT.0) THEN ISUB = SUBARR JSUB = 1 ELSE ISUB = 0 JSUB = -1 IF (APARM(3) .GT. 0.0001) JSUB = 1 END IF C polarization IF (CATUV(KINAX+JLOCS).EQ.CATBLK(KINAX+JLOCS)) THEN BPOL = 1 EPOL = MIN (2, CATBLK(KINAX+JLOCS)) ELSE TEMP = CATD(KDCRV+JLOCS) + (1 - CATR(KRCRP+JLOCS)) * * CATR(KRCIC+JLOCS) BPOL = ABS (IROUND (TEMP)) EPOL = MIN (2, CATBLK(KINAX+JLOCS)) EPOL = MAX (EPOL, BPOL) END IF C Revise tables: note depends on C doing loops 0 times if none OFQID = FRQSEL C copy BP tables only if C polarization callibration was C not applied CALL FNDEXT ('BP', CATUV, NVER) IF (DOBAND.GT.0) NVER = 0 DO 120 VER = 1,NVER CALL ISTAB ('BP', DISKIN, FCNO(2), VER, LUN1, BUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL BPSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, * BIF, LEIF, BCHAN, ECHAN, TB, TE, OFQID, ISUB, JSUB, BUFF1, * BUFF2, IRET) IF (IRET.GT.0) GO TO 999 120 CONTINUE C copy no CL table, even CL 1 has C calibration data supposing that C CL table cal was applied C NA number of selected antennas C AN(*) list of the sel. antennas CALL FNDEXT ('CL', CATUV, NVER) IF (ASSEMB) THEN IF ((DOCAL) .AND. (NVER.GT.0)) THEN VER = 1 CALL ISTAB ('CL', DISKIN, FCNO(2), VER, LUN1, BUFF1, TABLE, * EXIST, FITASC, IERR) C do NOT select on sources IF (EXIST .AND. (IERR.EQ.0)) THEN CALL CLNULL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, LEIF, OFQID, TB, * TE, 0, SOUWAN, AN, NA, ISUB, JSUB, IBUFF1, IBUFF2, * IRET) IF (IRET.GT.0) GO TO 999 IF (IRET.EQ.0) CALL CLTIDY (DISKO, FCNO(1), SOCOUN, VER, * IRET) END IF ELSE DO 140 VER = 1,NVER CALL ISTAB ('CL', DISKIN, FCNO(2), VER, LUN1, BUFF1, * TABLE, EXIST, FITASC, IERR) C do NOT select on sources IF (EXIST .AND. (IERR.EQ.0)) THEN CALL CLSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, * CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, LEIF, * OFQID, TB, TE, 0, SOUWAN, AN, NA, ISUB, JSUB, * IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 IF (IRET.EQ.0) CALL CLTIDY (DISKO, FCNO(1), SOCOUN, * VER, IRET) END IF 140 CONTINUE END IF END IF C CD tables CALL FNDEXT ('CD', CATUV, NVER) DO 145 VER = 1,NVER CALL ISTAB ('CD', DISKIN, FCNO(2), VER, LUN1, BUFF1, TABLE, * EXIST, FITASC, IERR) C do not select on antenna IF (EXIST.AND.(IERR.EQ.0)) CALL CDSEL (DISKIN, FCNO(2), DISKO, * FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, * LEIF, OFQID, AN, 0, ISUB, JSUB, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 145 CONTINUE C CP tables CALL FNDEXT ('CP', CATUV, NVER) DO 150 VER = 1,NVER CALL ISTAB ('CP', DISKIN, FCNO(2), VER, LUN1, BUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST.AND.(IERR.EQ.0)) CALL CPSEL (DISKIN, FCNO(2), DISKO, * FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BIF, LEIF, BCHAN, * ECHAN, OFQID, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 150 CONTINUE C CQ tables CALL FNDEXT ('CQ', CATUV, NVER) DO 160 VER = 1,NVER CALL ISTAB ('CQ', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST.AND.(IERR.EQ.0)) CALL CQSEL (DISKIN, FCNO(2), DISKO, * FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BIF, LEIF, OFQID, * ISUB, JSUB, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 160 CONTINUE C copy FG tables if flaging was C not applied CALL FNDEXT ('FG', CATUV, NVER) IF ((FGVER.GT.0) .AND. (NVER.GT.0)) THEN BVER = FGVER + 1 IF (NVER.LE.FGVER) THEN MSGTXT = 'WARNING: NO FG TABLES ARE COPIED SINCE HIGHEST' // * ' WAS APPLIED' NVER = 0 ELSE WRITE (MSGTXT,1160) BVER, NVER END IF CALL MSGWRT (6) END IF DO 180 VER = BVER,NVER CALL ISTAB ('FG', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0) .AND. (VER.GT.FGVER)) * CALL FGSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BIF, LEIF, BCHAN, ECHAN, TB, * TE, OFQID, ISUB, JSUB, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 180 CONTINUE C copy GC tables if calibration C was not applied CALL FNDEXT ('GC', CATUV, NVER) DO 200 VER = 1,NVER CALL ISTAB ('GC', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL GCSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, * BCHAN, ECHAN, BIF, LEIF, OFQID, AN, NA, ISUB, JSUB, IBUFF1, * IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 200 CONTINUE C IM tables CALL FNDEXT ('IM', CATUV, NVER) DO 220 VER = 1,NVER CALL ISTAB ('IM', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL IMSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, * BIF, LEIF, OFQID, TB, TE, NSOUWD, SOUWAN, AN, NA, ISUB, * JSUB, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 220 CONTINUE C MC tables CALL FNDEXT ('MC', CATUV, NVER) DO 240 VER = 1,NVER CALL ISTAB ('MC', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL MCSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, * BIF, LEIF, OFQID, TB, TE, NSOUWD, SOUWAN, AN, NA, ISUB, * JSUB, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 240 CONTINUE C copy PC tables if calibration C was not applied CALL FNDEXT ('PC', CATUV, NVER) IF (DOCAL) NVER = 0 DO 260 VER = 1,NVER CALL ISTAB ('PC', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL PCSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, * BIF, LEIF, OFQID, TB, TE, NSOUWD, SOUWAN, AN, NA, ISUB, * JSUB, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 260 CONTINUE C PD table if not applied CALL FNDEXT ('PD', CATUV, NVER) IF (DOPOL.LE.0) THEN DO 270 VER = 1,NVER CALL ISTAB ('PD', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL PDSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, * EPOL, BIF, LEIF, BCHAN, ECHAN, OFQID, ISUB, JSUB, IBUFF1, * IBUFF2, IRET) IF (IRET.NE.0) GO TO 999 270 CONTINUE END IF C copy SN tables if calibration C was not applied CALL FNDEXT ('SN', CATUV, NVER) IF (DOCAL) NVER = 0 DO 280 VER = 1,NVER CALL ISTAB ('SN', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) THEN IF (DOFLAG) THEN CALL SNFSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, LEIF, OFQID, TB, * TE, ISUB, JSUB, IBUFF1, IBUFF2, IRET) ELSE CALL SNSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, LEIF, OFQID, TB, * TE, ISUB, JSUB, IBUFF1, IBUFF2, IRET) END IF IF (IRET.GT.0) GO TO 999 END IF 280 CONTINUE C SY tables CALL FNDEXT ('SY', CATUV, NVER) DO 290 VER = 1,NVER CALL ISTAB ('SY', DISKIN, CNOIN, VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) THEN IF (DOFLAG) THEN CALL SYFSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, LEIF, OFQID, TB, * TE, NSOUWD, SOUWAN, AN, NA, ISUB, JSUB, IBUFF1, * IBUFF2, IRET) ELSE CALL SYSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, LEIF, OFQID, TB, * TE, NSOUWD, SOUWAN, AN, NA, ISUB, JSUB, IBUFF1, * IBUFF2, IRET) END IF IF (IRET.GT.0) GO TO 999 END IF 290 CONTINUE C SU tables CALL FNDEXT ('SU', CATUV, NVER) C Do not create SU table if only C one source is selected CALL AXEFND (8, 'SOURCE ', CATBLK(KIPCN), CATBLK(KHPTP), VER, * IERR) IF (IERR.NE.0) NVER = 0 DO 300 VER = 1,NVER CALL ISTAB ('SU', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) THEN CALL SUSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BIF, LEIF, OFQID, IBUFF1, IBUFF2, * CNTCHN(1), REFCOR, IRET) IF (IRET.GT.0) GO TO 999 IF (IRET.EQ.0) CALL SUTIDY (DISKO, FCNO(1), SOCOUN, VER, * IRET) END IF 300 CONTINUE C copy TY tables if calibration C was not applied CALL FNDEXT ('TY', CATUV, NVER) DO 320 VER = 1,NVER CALL ISTAB ('TY', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) THEN IF (DOFLAG) THEN CALL TYFSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, EIF, OFQID, TB, * TE, AN, NA, ISUB, JSUB, IBUFF1, IBUFF2, IRET) ELSE CALL TYSEL (DISKIN, FCNO(2), DISKO, FCNO(1), VER, CATUV, * CATBLK, LUN1, LUN2, BPOL, EPOL, BIF, LEIF, OFQID, TB, * TE, AN, NA, ISUB, JSUB, IBUFF1, IBUFF2, IRET) END IF IF (IRET.GT.0) GO TO 999 END IF 320 CONTINUE C WX tables CALL FNDEXT ('WX', CATUV, NVER) DO 340 VER = 1,NVER CALL ISTAB ('WX', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL WXSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, TB, TE, AN, * NA, ISUB, JSUB, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 340 CONTINUE C BL tables CALL FNDEXT ('BL', CATUV, NVER) IF (DOBL) NVER = 0 DO 350 VER = 1,NVER CALL ISTAB ('BL', DISKIN, FCNO(2), VER, LUN1, IBUFF1, TABLE, * EXIST, FITASC, IERR) IF (EXIST .AND. (IERR.EQ.0)) CALL BLSEL (DISKIN, FCNO(2), * DISKO, FCNO(1), VER, CATUV, CATBLK, LUN1, LUN2, BPOL, EPOL, * AN, NA, ISUB, JSUB, BIF, LEIF, OFQID, IBUFF1, IBUFF2, IRET) IF (IRET.GT.0) GO TO 999 350 CONTINUE C close FG IF (DOFLAG) CALL TABIO ('CLOS', 0, VER, IBUFF1, FGBUFF, IERR) C 999 RETURN C----------------------------------------------------------------------- 1160 FORMAT ('WARNING: ONLY FG TABLE VERSIONS',I4,' TO',I4,' COPIED') END SUBROUTINE SUTIDY (DISK, ISLOT, SOCOUN, IN, IERR) C----------------------------------------------------------------------- C Routine to tidy up the SU table after the loading has finished. C During loading the array SOCOUN(*) keeps track of how many entries C a particular source has, if any have zero then they are removed C from the SU table. C Inputs: C DISK I Volume on which data reside C ISLOT I Catalogue number of file C SOCOUN I(*) Array with # times source written C IN I input version number C Outputs: C IERR I Error code, 0 => OK. C----------------------------------------------------------------------- INTEGER DISK, ISLOT, SOCOUN(*), IN, IERR C INTEGER OUT, LUNIN, LUNOUT, BUFF1(512), BUFF2(512), I, NSOU INCLUDE 'INCS:PUVD.INC' C Declarations for SOUINI INTEGER SUKOLS(MAXSUC), SUNUMV(MAXSUC), ISURNO, NOBAND, * IFQ, SOKOLS(MAXSUC), SONUMV(MAXSUC), ISORNO CHARACTER VELTYP*8, VELDEF*8 C Declarations for TABSOU CHARACTER SOUNAM*16, TCALC*4 REAL FLUX(4,MAXIF) INTEGER IDSOU, TQUAL DOUBLE PRECISION FREQO(MAXIF), LSRVEL(MAXIF), LRESTF(MAXIF), * BANDW, TRAEPO, TDCEPO, TRAAPP, TDCAPP, TEQUIN, TPMRA, TPMDEC, * TRAOBS, TDECOB INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DCAT.INC' C----------------------------------------------------------------------- C Copy SU IN -> SU MAX + 1 OUT = 0 LUNIN = 45 LUNOUT = 46 I = MSGSUP MSGSUP = 32005 CALL TABCOP ('SU', IN, OUT, LUNIN, LUNOUT, DISK, DISK, ISLOT, * ISLOT, CATBLK, BUFF1, BUFF2, IERR) MSGSUP = I IF (IERR.NE.0) THEN WRITE (MSGTXT,1000) IERR GO TO 990 END IF C Delete SU 1 CALL RMEXT (DISK, ISLOT, 'SU', IN, CATBLK, BUFF1, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1010) IERR GO TO 990 END IF C Open SU table #2 CALL SOUINI ('READ', BUFF2, DISK, ISLOT, OUT, CATBLK, LUNOUT, * NOBAND, VELTYP, VELDEF, IFQ, ISURNO, SUKOLS, SUNUMV, IERR) IF (IERR.NE.0) THEN CALL TABERR ('READ', 'SOUINI', 'SUTIDY', IERR) GO TO 990 ENDIF NSOU = BUFF2(5) C Open SU table #1 CALL SOUINI ('WRIT', BUFF1, DISK, ISLOT, IN, CATBLK, LUNIN, * NOBAND, VELTYP, VELDEF, IFQ, ISORNO, SOKOLS, SONUMV, IERR) IF (IERR.NE.0) THEN CALL TABERR ('WRIT', 'SOUINI', 'SUTIDY', IERR) GO TO 990 ENDIF C Loop & copy DO 100 I = 1, NSOU ISURNO = I CALL TABSOU ('READ', BUFF2, ISURNO, SUKOLS, SUNUMV, IDSOU, * SOUNAM, TQUAL, TCALC, FLUX, FREQO, BANDW, TRAEPO, TDCEPO, * TEQUIN, TRAAPP, TDCAPP, TRAOBS, TDECOB, LSRVEL, LRESTF, * TPMRA, TPMDEC, IERR) IF (IERR.NE.0) THEN CALL TABERR ('READ', 'TABSOU', 'SUTIDY', IERR) GO TO 999 END IF C Check have valid data IF (SOCOUN(IDSOU).EQ.0) GO TO 100 C If so, write CALL TABSOU ('WRIT', BUFF1, ISORNO, SOKOLS, SONUMV, IDSOU, * SOUNAM, TQUAL, TCALC, FLUX, FREQO, BANDW, TRAEPO, TDCEPO, * TEQUIN, TRAAPP, TDCAPP, TRAOBS, TDECOB, LSRVEL, LRESTF, * TPMRA, TPMDEC, IERR) IF (IERR.NE.0) THEN CALL TABERR ('READ', 'TABSOU', 'SUTIDY', IERR) GO TO 999 END IF 100 CONTINUE C Close tables CALL TABIO ('CLOS', 1, ISURNO, BUFF2, BUFF2, IERR) IF (IERR.NE.0) THEN CALL TABERR ('CLOS', 'TABIO', 'SUTIDY', IERR) GO TO 999 END IF CALL TABIO ('CLOS', 1, ISORNO, BUFF1, BUFF1, IERR) IF (IERR.NE.0) THEN CALL TABERR ('CLOS', 'TABIO', 'SUTIDY', IERR) GO TO 999 END IF C Delete SU 2 CALL RMEXT (DISK, ISLOT, 'SU', OUT, CATBLK, BUFF2, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1010) IERR GO TO 990 END IF GO TO 999 C 990 CALL MSGWRT (8) C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT ('SUTIDY: ERROR',I3,' COPYING SU #1 -> SU #2') 1010 FORMAT ('SUTIDY: ERROR',I3,' DELETING SU #1') END SUBROUTINE CLTIDY (DISK, ISLOT, SOCOUN, IN, IERR) C----------------------------------------------------------------------- C Routine to tidy up the CL table after the loading has finished. C During loading the array SOCOUN(*) keeps track of how many entries C a particular source has, if any have zero then they are removed C from the SU table. C Inputs: C DISK I Volume on which data reside C ISLOT I Catalogue number of file C SOCOUN I(*) Array with # times source written C IN I input version number C Outputs: C IERR I Error code, 0 => OK. C----------------------------------------------------------------------- INTEGER DISK, ISLOT, SOCOUN(*), IN, IERR C INTEGER OUT, LUNIN, LUNOUT, BUFF1(512), BUFF2(512), I INCLUDE 'INCS:PUVD.INC' C Declarations for CALINI INTEGER CLKOLS(MAXCLC), CLNUMV(MAXCLC), ICLRNO, NUMANT, NUMPOL, * NUMIF, NTERM, SOKOLS(MAXCLC), SONUMV(MAXCLC), OCLRNO, NREC REAL GMMOD C Declarations for TABCAL DOUBLE PRECISION TIME, GEODLY(10) REAL TIMEI, IFR, DOPOFF(MAXIF), ATMOS, DATMOS, MBDELY(2), * CLOCK(2), DCLOCK(2), DISP(2), DDISP(2), * CREAL(2,MAXIF), CIMAG(2,MAXIF), DELAY(2,MAXIF), RATE(2,MAXIF), * WEIGHT(2,MAXIF) INTEGER SOURID, ANTNO, SUBA, FREQID, REFA(2,MAXIF) INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DCAT.INC' C----------------------------------------------------------------------- C Copy CL IN -> CL MAX + 1 OUT = 0 LUNIN = 45 LUNOUT = 46 I = MSGSUP MSGSUP = 32005 CALL TABCOP ('CL', IN, OUT, LUNIN, LUNOUT, DISK, DISK, ISLOT, * ISLOT, CATBLK, BUFF1, BUFF2, IERR) MSGSUP = I IF (IERR.NE.0) THEN WRITE (MSGTXT,1000) IERR GO TO 990 END IF C Delete CL 1 CALL RMEXT (DISK, ISLOT, 'CL', IN, CATBLK, BUFF1, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1010) IERR GO TO 990 END IF C Open CL table #2 CALL CALINI ('READ', BUFF2, DISK, ISLOT, OUT, CATBLK, LUNOUT, * ICLRNO, CLKOLS, CLNUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD, * IERR) IF (IERR.NE.0) THEN CALL TABERR ('READ', 'CALINI', 'CLTIDY', IERR) GO TO 990 ENDIF NREC = BUFF2(5) C Open CL table #1 CALL CALINI ('WRIT', BUFF1, DISK, ISLOT, IN, CATBLK, LUNIN, * OCLRNO, SOKOLS, SONUMV, NUMANT, NUMPOL, NUMIF, NTERM, GMMOD, * IERR) IF (IERR.NE.0) THEN CALL TABERR ('WRIT', 'CALINI', 'CLTIDY', IERR) GO TO 990 ENDIF C Loop & copy DO 100 I = 1,NREC ICLRNO = I CALL TABCAL ('READ', BUFF2, ICLRNO, CLKOLS, CLNUMV, NUMPOL, * NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, * GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, DISP, * DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IERR) IF (IERR.NE.0) THEN CALL TABERR ('READ', 'TABCAL', 'CLTIDY', IERR) GO TO 999 END IF C Check have valid data IF (SOCOUN(SOURID).GT.0) THEN C If so, write CALL TABCAL ('WRIT', BUFF1, OCLRNO, CLKOLS, CLNUMV, NUMPOL, * NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, * GEODLY, DOPOFF, ATMOS, DATMOS, MBDELY, CLOCK, DCLOCK, * DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, * IERR) IF (IERR.NE.0) THEN CALL TABERR ('READ', 'TABSOU', 'CLTIDY', IERR) GO TO 999 END IF END IF 100 CONTINUE C Close tables CALL TABIO ('CLOS', 1, ICLRNO, BUFF2, BUFF2, IERR) IF (IERR.NE.0) THEN CALL TABERR ('CLOS', 'TABIO', 'CLTIDY', IERR) GO TO 999 END IF CALL TABIO ('CLOS', 1, OCLRNO, BUFF1, BUFF1, IERR) IF (IERR.NE.0) THEN CALL TABERR ('CLOS', 'TABIO', 'CLTIDY', IERR) GO TO 999 END IF C Delete CL 2 CALL RMEXT (DISK, ISLOT, 'CL', OUT, CATBLK, BUFF2, IERR) IF (IERR.NE.0) THEN WRITE (MSGTXT,1010) IERR GO TO 990 END IF GO TO 999 C 990 CALL MSGWRT (8) C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT ('CLTIDY: ERROR',I3,' COPYING CL #1 -> CL #2') 1010 FORMAT ('CLTIDY: ERROR',I3,' DELETING CL #1') END SUBROUTINE AVGSUB (VIS, NUMPOL, NUMIF, NCHAVG, CHINC, NOUTCH, * JNCS, JNCIF, JNCF, ISB, VISOUT) C----------------------------------------------------------------------- C Routine to diminish number of frequency chanels averaging a C group of them. C Inputs: C VIS R(*) Array containing the input visibility data C (Re, Im, Wt) C NUMPOL I Number of polarizations C NUMIF I Number of IF's C NCHAVG I # channels to average to form 1 o/p channel C CHINC I increment in input channels to output C NOUTCH I # output channels C JNCS I Index for polzn in output array C JNCIF I Index for IF in output array C JNCF I Index for FREQ in output array C ISB I(*) Sidband of each IF C Output: C VISOUT R(*) Output visibility C----------------------------------------------------------------------- INTEGER NUMPOL, NUMIF, NCHAVG, CHINC, NOUTCH, JNCS, * JNCIF, JNCF, ISB(*) REAL VIS(*), VISOUT(*) C INCLUDE 'INCS:PUVD.INC' INTEGER LOOPS, LOOPIF, LOOPF, INDEX, INP, OUTDEX, I REAL SUMWT, SUMRE, SUMIM, WT, XNORM INCLUDE 'INCS:DUVH.INC' C----------------------------------------------------------------------- C Check increment in channel C selector array and default C values of start and stop C Select/average DO 70 LOOPS = 1,NUMPOL DO 60 LOOPIF = 1,NUMIF INDEX = 1 + (LOOPS-1)*INCS + (LOOPIF-1)*INCIF C Upper sideband IF (ISB(LOOPIF).GE.0) THEN DO 30 LOOPF = 1, NOUTCH OUTDEX = 1 + (LOOPS-1)*JNCS + (LOOPIF-1)*JNCIF + * (LOOPF-1)*JNCF SUMWT = 0.0 SUMRE = 0.0 SUMIM = 0.0 DO 20 I = 1,NCHAVG INP = INDEX + (((LOOPF-1)*CHINC) + I-1)*INCF WT = VIS(INP+2) IF (WT.GT.0.0) THEN SUMRE = SUMRE + VIS(INP)*WT SUMIM = SUMIM + VIS(INP+1)*WT SUMWT = SUMWT + WT END IF 20 CONTINUE XNORM = 1.0 IF (SUMWT.GT.1.0E-10) XNORM = 1.0 / SUMWT VISOUT(OUTDEX) = SUMRE * XNORM VISOUT(OUTDEX+1) = SUMIM * XNORM VISOUT(OUTDEX+2) = SUMWT 30 CONTINUE END IF C Lower sideband IF (ISB(LOOPIF).LT.0) THEN DO 50 LOOPF = NOUTCH, 1, -1 OUTDEX = 1 + (LOOPS-1)*JNCS + (LOOPIF-1)*JNCIF + * (LOOPF-1)*JNCF SUMWT = 0.0 SUMRE = 0.0 SUMIM = 0.0 DO 40 I = NCHAVG,1,-1 INP = INDEX + (((LOOPF-1)*CHINC) + I-1)*INCF WT = VIS(INP+2) IF (WT.GT.0.0) THEN SUMRE = SUMRE + VIS(INP)*WT SUMIM = SUMIM + VIS(INP+1)*WT SUMWT = SUMWT + WT END IF 40 CONTINUE XNORM = 1.0 IF (SUMWT.GT.1.0E-10) XNORM = 1.0 / SUMWT VISOUT(OUTDEX) = SUMRE * XNORM VISOUT(OUTDEX+1) = SUMIM * XNORM VISOUT(OUTDEX+2) = SUMWT 50 CONTINUE END IF 60 CONTINUE 70 CONTINUE C 999 RETURN END SUBROUTINE AVGTIM (SOLINT, NOUTCH, NUMIF, NOPOL, XCOUNT, RPARM, * BUFF1, BUFF2, BUFF3, NBASL, OUTCOM, LLOCWT, OUTSOU, LLOCSU, * NUMSOU, NRPRIN,JNCIF, JNCS, JNCF, NCORR, BIND, I, LUN, EOF, * DTUTC, FIND, ANOTA, NPR, RBUFF, NPD, DBUFF, RNXRET, IRET) C----------------------------------------------------------------------- C AVGTIM averages the visibilities in time axis C Input: C SOLINT R Time of averaging in days C NOUTCH I Number of frequencies at the output file C NUMIF I Number of IFs at the output file C NOPOL I Number of polarization at the output file C RPARM R(20) Output random parameters C BUFF1 R(*) Array of read visibilities C BUFF2 R(*) Array used for writing data C BUFF3 R(*) Intermediate array C NBASL I Number of baseline C OUTCOM L If TRUE write compressed data C LLOCWT I Offset of compressed weight r.p in output data C OUTSOU L Force source number to random parameters C LLOCSU I Where to force it C NRPRIN I # random parms in uncompressed vis record C JNCIF I Increment in IF of data C JNCS I Increment in Stokes' of data C JNCF I Increment in frequencies of data C NCORR I Length of the vis part at BUFF1 C I I The read visibility number C LUN I Number of device C EOF L End of file C DTUTC R Time difference of data and UTC, days C NPR I Number parameters per baseline (incl overhead) C NPD I Number data words / baseline C Input/Output: C XCOUNT I Number of visibilities C BIND I Pointer at the output data C RBUFF R(*) Random parameter summing area C DBUFF R(*) Data summing area C Output: C BUFF1 R(*) Output I/O buffer. C BUFF2 R(*) Buffer for compressed data C BUFF3 R(*) Buffer to store the read data C IRET I Return error code, 0=>OK, otherwise error. C----------------------------------------------------------------------- INTEGER NOUTCH, NUMIF, NOPOL, XCOUNT, NBASL, LLOCWT, LLOCSU, * NUMSOU, NRPRIN, JNCIF, JNCS, JNCF, NCORR, BIND, I, LUN, FIND, * ANOTA(*), NPR, NPD, RNXRET, IRET LOGICAL OUTCOM, OUTSOU, EOF REAL SOLINT, RPARM(*), BUFF1(*), BUFF2(*), BUFF3(*), * DBUFF(NPD,*), RBUFF(NPR,*) C INTEGER NIO, K, IBAS, KBAS, CURSOU, LOOPS, LOOPIF, LOOPF, INDEX, * INP, LBIND, IDAY, IROUND, PRESOU, L, J, ICUR, IP, RNXSOR, * CURA1, CURA2, CURSA REAL CURTMI, XNORM, WT, SUMWT, DTUTC, WTOUT, CURBAS DOUBLE PRECISION X8, CURTIM, ENDTIM, INTTIM LOGICAL NEXT SAVE KBAS, PRESOU, ENDTIM INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DUVH.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'NEWHD.INC' C----------------------------------------------------------------------- J = NRPRIN + NPD CALL RCOPY (NRPRIN, RPARM, BUFF3(1)) CALL RCOPY (NPD, BUFF1, BUFF3(NRPRIN+1)) C First call IF (I.EQ.1) THEN C initialize the buffer of C accumulated visibilities J = NPD * NBASL CALL RFILL (J, 0.0, DBUFF) J = NPR * NBASL CALL RFILL (J, 0.0, RBUFF) KBAS = 0 PRESOU = 0 IF (MLOCSU.GT.-1) PRESOU = IROUND(BUFF3(1+MLOCSU)) CURTIM = BUFF3(1+MLOCT) - DTUTC IDAY = CURTIM X8 = (CURTIM-IDAY) / SOLINT C current time in integers of C SOLINT INTTIM = IDAY + DINT (X8) * SOLINT ENDTIM = INTTIM + SOLINT END IF C store BIND before it's changed C after UVDISK('WRIT'..) LBIND = 1 CURTIM = BUFF3(LBIND+MLOCT) - DTUTC IF (MLOCB.GE.0) THEN CURBAS = BUFF3(LBIND+MLOCB) ELSE CURA1 = BUFF3(LBIND+MLOCA1) + 0.1 CURA2 = BUFF3(LBIND+MLOCA2) + 0.1 CURSA = BUFF3(LBIND+MLOCSA) + 0.1 END IF CURSOU = 0 IF (MLOCSU.GT.-1) CURSOU = IROUND(BUFF3(LBIND+MLOCSU)) C NEXT = (CURTIM.GT.ENDTIM) .OR. (CURSOU.NE.PRESOU) NEXT = NEXT .OR. EOF IF (NEXT) THEN C evaluate averaged times DO 10 L = 1,KBAS WT = RBUFF(NRPRIN+1,L) IF (WT.GT.0.0) THEN DO 5 IP = 1,NRPRIN IF (ANOTA(IP).EQ.2) RBUFF(IP,L) = RBUFF(IP,L) / WT 5 CONTINUE RBUFF(NRPRIN+2,L) = RBUFF(1+MLOCT,L) ELSE RBUFF(NRPRIN+2,L) = FBLANK END IF 10 CONTINUE C sort the average data by time DO 80 L = 1,KBAS CURTMI = 1.0E10 DO 15 K = 1,KBAS IF (RBUFF(NRPRIN+2,K).NE.FBLANK) THEN IF (RBUFF(1+MLOCT,K).LT.CURTMI) THEN CURTMI = RBUFF(1+MLOCT,K) ICUR = K END IF END IF 15 CONTINUE RBUFF(NRPRIN+2,ICUR) = FBLANK K = ICUR C Random parameters CALL RCOPY (NRPRIN, RBUFF(1,K), BUFF2(BIND)) IF (OUTSOU) THEN BUFF2(BIND+LLOCSU) = NUMSOU RNXSOR = NUMSOU ELSE RNXSOR = 1 END IF C update NX table CALL RNXUPD (BUFF2(BIND), RNXSOR, RNXRET) C data DO 60 LOOPS = 1,NOPOL DO 40 LOOPIF = 1,NUMIF DO 20 LOOPF = 1, NOUTCH INP = 1 + (LOOPS-1)*JNCS + (LOOPIF-1)*JNCIF + * (LOOPF-1)*JNCF XNORM = 1.0 SUMWT = DBUFF(INP+2,K) IF (SUMWT.GT.1.0E-10) XNORM = 1.0 / SUMWT BUFF1(INP) = DBUFF(INP,K) * XNORM BUFF1(INP+1) = DBUFF(INP+1,K) * XNORM BUFF1(INP+2) = SUMWT 20 CONTINUE 40 CONTINUE 60 CONTINUE C Write new NIO = 1 XCOUNT = XCOUNT + 1 IF (OUTCOM) THEN CALL ZUVPAK (NCORR, BUFF1, BUFF2(BIND+LLOCWT), * BUFF2(BIND+NRPRIN)) ELSE CALL RCOPY (3*NCORR, BUFF1, BUFF2(BIND+NRPRIN)) END IF CALL UVDISK ('WRIT', LUN, FIND, BUFF2, NIO, BIND, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1060) IRET GO TO 990 END IF 80 CONTINUE C C initialize the buffer of C accumulated visibilities J = NPD * NBASL CALL RFILL (J, 0.0, DBUFF) J = NPR * NBASL CALL RFILL (J, 0.0, RBUFF) KBAS = 0 C new interval at the same source IF (CURSOU.EQ.PRESOU) THEN 90 IF (CURTIM.GT.ENDTIM) THEN ENDTIM = ENDTIM + SOLINT GO TO 90 END IF ELSE IDAY = CURTIM X8 = (CURTIM-IDAY) / SOLINT C current time in integers of C SOLINT INTTIM = IDAY + DINT (X8) * SOLINT ENDTIM = INTTIM + SOLINT END IF PRESOU = CURSOU END IF C find a baseline number IBAS = 0 IF (MLOCB.GE.0) THEN DO 100 K = 1,KBAS IF (ABS(CURBAS-RBUFF(1+MLOCB,K)).LT.0.001) IBAS = K 100 CONTINUE ELSE DO 105 K = 1,KBAS IF ((ABS(CURA1-RBUFF(1+MLOCA1,K)).LT.0.001) .AND. * (ABS(CURA2-RBUFF(1+MLOCA2,K)).LT.0.001) .AND. * (ABS(CURSA-RBUFF(1+MLOCSA,K)).LT.0.001)) IBAS = K 105 CONTINUE END IF IF (IBAS.LE.0) THEN IF (KBAS.GE.NBASL) THEN IF (MLOCB.GE.0) THEN IP = CURBAS / 256.0 ICUR = CURBAS - 256 * IP WRITE (MSGTXT,1100) IP, ICUR ELSE WRITE (MSGTXT,1100) CURA1, CURA2 END IF IRET = 1 GO TO 990 END IF KBAS = KBAS + 1 IBAS = KBAS END IF DO 130 LOOPS = 1,NOPOL DO 120 LOOPIF = 1,NUMIF DO 110 LOOPF = 1,NOUTCH INDEX = 1 + (LOOPS-1)*JNCS + (LOOPIF-1)*JNCIF + * (LOOPF-1)*JNCF INP = INDEX + NRPRIN WT = BUFF3(INP+2) IF (WT.GT.0.0) THEN WTOUT = MAX (WT, WTOUT) DBUFF(INDEX,IBAS) = DBUFF(INDEX,IBAS) + BUFF3(INP)*WT DBUFF(INDEX+1,IBAS) = DBUFF(INDEX+1,IBAS) * + BUFF3(INP+1)*WT DBUFF(INDEX+2,IBAS) = DBUFF(INDEX+2,IBAS) + WT END IF 110 CONTINUE 120 CONTINUE 130 CONTINUE DO 200 IP = 1,NRPRIN C weighted average variables IF (ANOTA(IP).EQ.2) THEN RBUFF(IP,IBAS) = RBUFF(IP,IBAS) + WTOUT*BUFF3(IP) C no weight for summed variables ELSE IF (ANOTA(IP).EQ.1) THEN RBUFF(IP,IBAS) = RBUFF(IP,IBAS) + BUFF3(IP) ELSE IF (RBUFF(IP,IBAS).EQ.0.0) RBUFF(IP,IBAS) = BUFF3(IP) END IF 200 CONTINUE RBUFF(NRPRIN+1,IBAS) = RBUFF(NRPRIN+1,IBAS) + WTOUT GO TO 999 C Error 990 CALL MSGWRT (8) C 999 RETURN C----------------------------------------------------------------------- 1060 FORMAT ('AVGTIM: ERROR',I5,' WRITING OUTPUT FILE') 1100 FORMAT ('AVGTIM: TOO MANY BASELINES FOR BUFFER AT',I2,' - ',I2) END SUBROUTINE SUSEL (DISKI, CNOI, DISKO, CNOO, VER, CATIN, CATOUT, * LUNI, LUNO, BIF, EIF, IFQID, BUFFER, OBUFF, CNTCHN, REFCOR, * IRET) C----------------------------------------------------------------------- C Copies a subset of IFs in an SU table. C Inputs: C DISKI I Input volume number C CNOI I Input catalog number C DISKO I Output volume number C CNOO I Output catalog number C VER I Version to check/modify C CATIN(256) I Input catalog header C CATOUT(256) I Output catalog header C LUNI I LUN to use C LUNO I LUN to use C BIF I Start IF number C EIF I End IF number C IFQID I FQ ID to select C CNTCHN I Number of averaged frequency channels C REFCOR R Correction of the reference channel C Input/Output: C BUFFER I(*) Work buffer C OBUFF I(*) Work buffer C Output: C IRET I Error, 0 => OK C----------------------------------------------------------------------- INTEGER DISKI, CNOI, DISKO, CNOO, VER, CATIN(256), * CATOUT(256), LUNI, LUNO, BIF, EIF, IFQID, BUFFER(*), * OBUFF(*), CNTCHN, IRET C INCLUDE 'INCS:PUVD.INC' CHARACTER VELTYP*8, VELDEF*8, SOUNAM*16, CALCOD*4 INTEGER ISURNO, SUKOLS(MAXSUC), SUNUMV(MAXSUC), NUMIF, * OKOLS(MAXSUC), ONUMV(MAXSUC), NSUROW, I, IIF, JIF, OSURNO, * NEWNIF, IDSOU, QUAL, SUFQID, OVER LOGICAL REFMT REAL FLUX(4,MAXIF), REFCOR DOUBLE PRECISION FREQO(MAXIF), BANDW, RAEPO, DECEPO, EPOCH, * RAAPP, DECAPP, LSRVEL(MAXIF), LRESTF(MAXIF), PMRA, PMDEC, * RAOBS, DECOBS INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DHDR.INC' C----------------------------------------------------------------------- C Open SU file CALL SOUINI ('READ', BUFFER, DISKI, CNOI, VER, CATIN, LUNI, * NUMIF, VELTYP, VELDEF, SUFQID, ISURNO, SUKOLS, SUNUMV, IRET) IF (IRET.EQ.2) THEN IRET = 0 GO TO 999 END IF IF (IRET.NE.0) THEN WRITE (MSGTXT,1010) IRET GO TO 990 END IF C New no. of IFs NEWNIF = MAX (MIN (NUMIF, EIF) - BIF + 1, 0) REFMT = NEWNIF.NE.NUMIF C # rows in old table NSUROW = BUFFER(5) C Open up new SU table OVER = VER IF (SUFQID.EQ.-999) SUFQID = -1 C Check selected FQ ID IF ((SUFQID.EQ.IFQID).AND.(IFQID.GT.0)) SUFQID = 1 IF ((SUFQID.NE.IFQID).AND.(IFQID.GT.0)) SUFQID = -1 C CALL SOUINI ('WRIT', OBUFF, DISKO, CNOO, OVER, CATOUT, LUNO, * NEWNIF, VELTYP, VELDEF, SUFQID, OSURNO, OKOLS, ONUMV, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1010) IRET GO TO 990 END IF C Loop and copy DO 100 I = 1, NSUROW CALL TABSOU ('READ', BUFFER, ISURNO, SUKOLS, SUNUMV, * IDSOU, SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, * DECEPO, EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF, * PMRA, PMDEC, IRET) IF (IRET.GT.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 END IF C De-selected record IF (NEWNIF.EQ.0) GO TO 100 C Select IFs DO 90 JIF = 1, NEWNIF IIF = JIF + BIF - 1 FREQO(JIF) = FREQO(IIF) LSRVEL(JIF) = LSRVEL(IIF) C correct the reference frequency LRESTF(JIF) = LRESTF(IIF) + REFCOR * BANDW FLUX(1,JIF) = FLUX(1,IIF) FLUX(2,JIF) = FLUX(2,IIF) FLUX(3,JIF) = FLUX(3,IIF) FLUX(4,JIF) = FLUX(4,IIF) 90 CONTINUE C change bandwidth in accordance C of number of averaged frequency C channels IF (CNTCHN.GT.0) BANDW = BANDW * CNTCHN C Write new one CALL TABSOU ('WRIT', OBUFF, OSURNO, OKOLS, ONUMV, IDSOU, * SOUNAM, QUAL, CALCOD, FLUX, FREQO, BANDW, RAEPO, DECEPO, * EPOCH, RAAPP, DECAPP, RAOBS, DECOBS, LSRVEL, LRESTF, PMRA, * PMDEC, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 END IF 100 CONTINUE C Close both tables CALL TABIO ('CLOS', 0, ISURNO, BUFFER, BUFFER, IRET) CALL TABIO ('CLOS', 0, OSURNO, OBUFF, OBUFF, IRET) IF ((MSGSUP.LT.31990) .OR. (MSGSUP.GE.32000)) THEN IF (REFMT) THEN WRITE (MSGTXT,1100) 'Reformatted SU', DISKI, CNOI, VER, * DISKO, CNOO, OVER ELSE WRITE (MSGTXT,1100) 'Copied SU', DISKI, CNOI, VER, DISKO, * CNOO, OVER END IF CALL MSGWRT (3) END IF GO TO 999 C Error 990 CALL MSGWRT (6) C 999 RETURN C----------------------------------------------------------------------- 1010 FORMAT ('SUSEL: ERROR ',I3,' RETURNED FROM SOUINI') 1020 FORMAT ('SUSEL: ERROR ',I3,' RETURNED FROM TABSOU') 1100 FORMAT (A,' file from vol/cno/vers',I3,I5,I4,' to',I3,I5,I4) END SUBROUTINE PRMSET (CATBLK, TRN) C----------------------------------------------------------------------- C Drops REMOVED from random parameter list and makes list of output C indices C In/Out: C CATBLK I(256) Catalog header - input random parms can have C REMOVED - output does not (and # changed) C Output: C TRN I(14) output parm(j) = input parm(trn(j)) C----------------------------------------------------------------------- INTEGER CATBLK(256), TRN(*) C INTEGER NPI, NPO, I CHARACTER TYPE*8 INCLUDE 'INCS:DHDR.INC' C----------------------------------------------------------------------- NPO = 0 NPI = CATBLK(KIPCN) DO 20 I = 1,NPI CALL H2CHR (8, 1, CATBLK(KHPTP+2*I-2), TYPE) IF (TYPE.NE.'REMOVED') THEN NPO = NPO + 1 TRN(NPO) = I CALL CHR2H (8, TYPE, 1, CATBLK(KHPTP+2*NPO-2)) END IF 20 CONTINUE CATBLK(KIPCN) = NPO C 999 RETURN END SUBROUTINE RNXUPD (RPARM, DEFSRC, IRET) C----------------------------------------------------------------------- C Updates tables in core if needed, and if necessary, write a new C NX table record. SPLAT version with added arg DEFSRC C Inputs: C RPARM R(*) Random parameters C DEFSRC I Source number to use if no source parameter in C data C In/output: C IRET I Error code: input IRET unchanged if failure flag C is set (RNXRNO < 0) C----------------------------------------------------------------------- INTEGER DEFSRC, IRET REAL RPARM(*) C INTEGER IA1, IA2, CURSUB, CURSOU, CURFQI, ISUB REAL CURTIM, TEMP, GAP, LENGTH, CTIME, DTIME, T INCLUDE 'INCS:DRNX.INC' INCLUDE 'INCS:DUVH.INC' INCLUDE 'INCS:DMSG.INC' INCLUDE 'NEWHD.INC' C----------------------------------------------------------------------- C leave if not doing IF (RNXRNO.LE.0) GO TO 999 IRET = 0 C parameters of this record IF (MLOCB.GE.0) THEN TEMP = RPARM(1+MLOCB) IA1 = TEMP / 256.0 + 0.001 IA2 = TEMP - 256 * IA1 + 0.01 CURSUB = 100.0 * (TEMP - IA1*256 -IA2) + 1.5 ELSE IA1 = RPARM(1+MLOCA1) + 0.1 IA2 = RPARM(1+MLOCA2) + 0.1 CURSUB = RPARM(1+MLOCSA) + 0.1 END IF IF (MLOCSU.GE.0) THEN CURSOU = RPARM(1+MLOCSU) ELSE CURSOU = DEFSRC END IF IF (MLOCFQ.GE.0) THEN CURFQI = RPARM(1+MLOCFQ) ELSE CURFQI = 1 END IF CURTIM = RPARM(1+MLOCT) C new vis RNXVIS = RNXVIS + 1 C start of scan IF (RNXANT(CURSUB).EQ.0) THEN VSTART(CURSUB) = RNXVIS STIME(CURSUB) = CURTIM SRC(CURSUB) = CURSOU FQID(CURSUB) = CURFQI 10 IF (RNXNOS(CURSUB).GT.0) THEN IF (CURTIM.GT.RNXTSC(RNXCUR(CURSUB)+1)) THEN RNXCUR(CURSUB) = RNXCUR(CURSUB) + 1 IF (RNXCUR(CURSUB)-RNXFIR(CURSUB)+1.GE.RNXNOS(CURSUB)) * RNXNOS(CURSUB) = 0 GO TO 10 END IF END IF C Time has gone down! ELSE IF (CURTIM.LT.ETIME(CURSUB)) THEN GAP = CURTIM - ETIME(CURSUB) STIME(CURSUB) = MIN (STIME(CURSUB), CURTIM) IF (GAP.LT.-MAXGAP) THEN IRET = 1 MSGTXT = 'RNXUPD: DATA SERIOUSLY OUT OF TIME ORDER' GO TO 990 END IF C Time has increased ELSE IF (CURTIM.GT.ETIME(CURSUB)) THEN C use previous info IF (RNXNOS(CURSUB).GT.0) THEN GAP = 0.0 LENGTH = 0.0 15 IF (CURTIM.GT.RNXTSC(RNXCUR(CURSUB)+1)) THEN RNXCUR(CURSUB) = RNXCUR(CURSUB) + 1 LENGTH = 2. * MAXLEN IF (RNXCUR(CURSUB)-RNXFIR(CURSUB)+1.GE.RNXNOS(CURSUB)) * THEN RNXNOS(CURSUB) = 0 ELSE GO TO 15 END IF END IF C figure it out ourselves ELSE GAP = CURTIM - ETIME(CURSUB) LENGTH = CURTIM - STIME(CURSUB) C try to find proper maxgap IF ((NGAPS.GE.0) .AND. (GAP.GT.RNXEPS) .AND. (GAP.LE.MAXGAP) * .AND. (CURSOU.EQ.SRC(CURSUB)) .AND. * (CURFQI.EQ.FQID(CURSUB))) THEN T = MAX (10.0*SGAPS/NGAPS, 0.0007) IF (NGAPS.EQ.0) THEN NGAPS = 1 SGAPS = GAP ELSE IF ((NGAPS.GT.1) .AND. (GAP.GT.T)) THEN MAXGAP = (GAP + T)/2 NGAPS = -1 ELSE NGAPS = NGAPS + 1 SGAPS = SGAPS + GAP END IF END IF END IF C close this scan IF ((LENGTH.GT.MAXLEN) .OR. (GAP.GT.MAXGAP) .OR. * (CURSOU.NE.SRC(CURSUB)) .OR. (CURFQI.NE.FQID(CURSUB))) THEN C dump others?? DO 20 ISUB = 1,MAXSUB IF ((RNXANT(ISUB).GT.0) .AND. (ISUB.NE.CURSUB) .AND. * (ETIME(ISUB).LT.STIME(CURSUB))) THEN CTIME = (ETIME(ISUB) + STIME(ISUB)) / 2.0 DTIME = ETIME(ISUB) - STIME(ISUB) CALL TABNDX ('WRIT', RNXBUF, RNXRNO, RNXKOL, RNXNUM, * CTIME, DTIME, SRC(ISUB), ISUB, VSTART(ISUB), * VEND(ISUB), FQID(ISUB), IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1000) IRET, 'WRITE NX TABLE' GO TO 990 END IF RNXANT(ISUB) = 0 END IF 20 CONTINUE C now write current CTIME = (ETIME(CURSUB) + STIME(CURSUB)) / 2.0 DTIME = ETIME(CURSUB) - STIME(CURSUB) CALL TABNDX ('WRIT', RNXBUF, RNXRNO, RNXKOL, RNXNUM, * CTIME, DTIME, SRC(CURSUB), CURSUB, VSTART(CURSUB), * VEND(CURSUB), FQID(CURSUB), IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1000) IRET, 'WRITE NX TABLE' GO TO 990 END IF C Set up new scan: RNXANT(CURSUB) = 0 VSTART(CURSUB) = RNXVIS STIME(CURSUB) = CURTIM SRC(CURSUB) = CURSOU FQID(CURSUB) = CURFQI END IF END IF C Update scan information: VEND(CURSUB) = RNXVIS ETIME(CURSUB) = CURTIM RNXANT(CURSUB) = 1 GO TO 999 C 990 CALL MSGWRT (8) RNXRNO = -1 C 999 RETURN C----------------------------------------------------------------------- 1000 FORMAT ('RNXUPD: ERROR',I3,' DOING ',A) END SUBROUTINE TYFSEL (DISKI, CNOI, DISKO, CNOO, VER, CATIN, CATOUT, * LUNI, LUNO, BPOL, EPOL, BIF, EIF, IFQID, TB, TE, AN, NA, ISUB, * JSUB, BUFFER, OBUFF, IRET) C----------------------------------------------------------------------- C Copies a subset of IFs in a TY table, can also modify the FQ ID C Inputs: C DISKI I Input volume number C CNOI I Input catalog number C DISKO I Output volume number C CNOO I Output catalog number C VER I Version to check/modify C CATIN I(256) Input catalog header C LUNI I p LUN to use C LUNO I LUN to use C BIF I Start IF number C EIF I End IF number C IFQID I FQ ID to select (output value is 1) C if <= 0 then output value unchanged. C TB D Beginning time in days C TE D Ending time in days C AN I(*) Array of selected antennas C NA I Number of selected antennas C ISUB I Selected subarray (= 0 any) C JSUB I Output subarray number (< 0 => NO CHANGE) C Input/Output: C CATOUT I(256) Output catalog header C BUFFER I(*) Work buffer C OBUFF I(*) Work buffer C Output: C IRET I Error, 0 => OK C----------------------------------------------------------------------- INTEGER DISKI, CNOI, DISKO, CNOO, VER, CATIN(256), CATOUT(256), * LUNI, LUNO, BPOL, EPOL, BIF, EIF, IFQID, AN(8), NA, ISUB, JSUB, * BUFFER(*), OBUFF(*), IRET DOUBLE PRECISION TB, TE C C INCLUDE 'INCS:PUVD.INC' INTEGER ITYRNO, TYKOLS(MAXTYC), TYNUMV(MAXTYC), NUMPOL, NUMIF, * OKOLS(MAXTYC), ONUMV(MAXTYC), NTYROW, I, OVER, SOURID, ANTNO, * SUBA, FREQID, OTYRNO, NEWNIF, IIF, JIF, IPOL, K, NDEL, NTOT, * JRET, LBPOL, NEWPOL LOGICAL REFMT, GOTIT, GOTONE REAL TIME, TIMEI, TSYS(2,MAXIF), TANT(2,MAXIF) INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:PFLG.INC' INCLUDE 'INCS:DFLG.INC' C----------------------------------------------------------------------- C open flag table TMFLST = -1.E20 NUMFLG = 0 IFGRNO = 1 NDEL = 0 NTOT = 0 C Open TY file CALL TYINI ('READ', BUFFER, DISKI, CNOI, VER, CATIN, LUNI, ITYRNO, * TYKOLS, TYNUMV, NUMPOL, NUMIF, IRET) IF (IRET.EQ.2) THEN IRET = 0 GO TO 999 END IF IF (IRET.NE.0) THEN WRITE (MSGTXT,1010) IRET GO TO 990 END IF C New no. of IFs NEWNIF = MAX (MIN (NUMIF, EIF) - BIF + 1, 0) LBPOL = MAX (1, BPOL) NEWPOL = MIN (2, MIN (NUMPOL, EPOL)) - LBPOL + 1 IF (NEWPOL.LE.0) THEN NEWPOL = NUMPOL LBPOL = 1 END IF REFMT = (NEWNIF.NE.NUMIF) .OR. (NEWPOL.NE.NUMPOL) C # rows in old table NTYROW = BUFFER(5) C Open up new TY table OVER = VER CALL TYINI ('WRIT', OBUFF, DISKO, CNOO, OVER, CATOUT, LUNO, * OTYRNO, OKOLS, ONUMV, NEWPOL, NEWNIF, IRET) IF (IRET.GT.0) THEN WRITE (MSGTXT,1010) IRET GO TO 990 END IF C Loop and copy DO 100 I = 1,NTYROW CALL TABTY ('READ', BUFFER, ITYRNO, TYKOLS, TYNUMV, NUMPOL, * NUMIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, TSYS, TANT, * IRET) C Error reading table IF (IRET.GT.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 C check subarray, time ELSE IF (IRET.EQ.0) THEN CALL TYFLG (NUMPOL, NUMIF, TIME, SOURID, ANTNO, SUBA, * FREQID, TSYS, TANT, JRET) IF (JRET.GT.0) THEN IRET = JRET GO TO 999 END IF IF ((SUBA.GT.0) .AND. (ISUB.GT.0) .AND. (ISUB.NE.SUBA)) * IRET = -1 IF ((TIME.LT.TB) .OR. (TIME.GT.TE)) IRET = -1 IF ((IFQID.GT.0) .AND. (FREQID.GT.0) .AND. * (IFQID.NE.FREQID)) IRET = -1 C antenna IF ((NA.GT.0) .AND. (ANTNO.GT.0)) THEN GOTIT = .FALSE. DO 30 K = 1,NA GOTIT = GOTIT .OR. (ANTNO.EQ.AN(K)) 30 CONTINUE IF (.NOT.GOTIT) IRET = -1 END IF IF ((JRET.EQ.-1) .AND. (IRET.EQ.0)) THEN IRET = -1 NDEL = NDEL + 1 END IF END IF C Is this record selected ? IF ((IRET.LT.0) .OR. (NEWNIF.EQ.0)) THEN REFMT = .TRUE. C Select IFs ELSE GOTONE = .FALSE. DO 90 JIF = 1,NEWNIF IIF = JIF + BIF - 1 DO 80 IPOL = 1,NEWPOL K = IPOL + LBPOL - 1 TSYS(IPOL,JIF) = TSYS(K,IIF) TANT(IPOL,JIF) = TANT(K,IIF) IF (TSYS(IPOL,JIF).NE.FBLANK) GOTONE = .TRUE. IF (TANT(IPOL,JIF).NE.FBLANK) GOTONE = .TRUE. 80 CONTINUE 90 CONTINUE C Write new one IF (GOTONE) THEN IF (IFQID.GT.0) FREQID = 1 IF (JSUB.GE.0) SUBA = JSUB NTOT = NTOT + 1 CALL TABTY ('WRIT', OBUFF, OTYRNO, OKOLS, ONUMV, NEWPOL, * NEWNIF, TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, * TSYS, TANT, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 END IF ELSE REFMT = .TRUE. END IF END IF 100 CONTINUE IRET = 0 C Close both tables CALL TABIO ('CLOS', 0, ITYRNO, BUFFER, BUFFER, IRET) CALL TABIO ('CLOS', 0, OTYRNO, OBUFF, OBUFF, IRET) IF ((MSGSUP.LT.31990) .OR. (MSGSUP.GE.32000)) THEN IF (REFMT) THEN WRITE (MSGTXT,1100) 'Reformatted TY', DISKI, CNOI, VER, * DISKO, CNOO, OVER ELSE WRITE (MSGTXT,1100) 'Copied TY', DISKI, CNOI, VER, DISKO, * CNOO, OVER END IF CALL MSGWRT (3) NTOT = NTOT + NDEL WRITE (MSGTXT,1101) NDEL, NTOT CALL REFRMT (MSGTXT, '_', I) CALL MSGWRT (3) END IF GO TO 999 C Error 990 CALL MSGWRT (6) C 999 RETURN C----------------------------------------------------------------------- 1010 FORMAT ('TYFSEL: ERROR ',I3,' RETURNED FROM TYINI') 1020 FORMAT ('TYFSEL: ERROR ',I3,' RETURNED FROM TABTY') 1100 FORMAT (A,' file from vol/cno/vers',I3,I5,I4,' to',I3,I5,I4) 1101 FORMAT ('__Fully deleted',I10,' of',I12,' TY records applying', * ' flag table') END SUBROUTINE TYFLG (NPOL, NIF, TIME, SOURID, ANTNO, SUBA, * FREQID, TSYS, TANT, IRET) C----------------------------------------------------------------------- C Flags a TY table row based on the flags in FG table loaded to Common C Inputs: C NPOL I Number polarizations in TY data C NIF I Number of IFs in those data C TIME R Time of table row C SOURID I Source number of row C ANTNO I Antenna number of row C SUBA I Subarray of row C FREQID I Frequency ID if row C In/Out: C TSYS R(*) System temperature array - flagged -> FBLANK C TANT R(*) Antenna temperature array C Inputs from include DSEL.INC: C NUMFLG I Number of flagging entries. C TMFLST R Time of last visibility for which flagging C was checked. C FLGSOU(*) I Source id numbers to flag, 0=all. C FLGANT(*) I Antenna numbers to flag, 0=all. C FLGBAS(*) I Baseline (A1*32768+A2) numbers to flag, 0=all. C FLGSUB(*) I Subarray numbers to flag, 0=all. C FLGFQD(*) I Freqid numbers to flag, <=0=all. C Following should have defaults filled in. C FLGBIF(*) I First IF to flag. C FLGEIF(*) I Highest IF to flag. C FLGBCH(*) I First channel to flag. C FLGECH(*) I Highest channel to flag. C FLGPOL(4,*)L Flags for the polarizations, should correspond C to selected polarization types. C Output: C IRET I 0 -> okay, -1 -> all flagged C----------------------------------------------------------------------- INTEGER NPOL, NIF, SOURID, ANTNO, SUBA, FREQID, IRET REAL TIME, TSYS(2,*), TANT(2,*) C INTEGER IFLAG, FLGA, JPOLN, JIF, LIMF1, LIMF2, IPOLPT INCLUDE 'INCS:PUVD.INC' INCLUDE 'INCS:PFLG.INC' INCLUDE 'INCS:DFLG.INC' INCLUDE 'INCS:DDCH.INC' C----------------------------------------------------------------------- IRET = 0 IF (TMFLST.LT.TIME) CALL NXTFLG (TIME, .TRUE., IRET) IF (IRET.NE.0) GO TO 999 IF (NUMFLG.LE.0) GO TO 999 C loop over current flags DO 50 IFLAG = 1,NUMFLG C Check time if needed IF ((TIME.LT.FLGTST(IFLAG)) .OR. (TIME.GT.FLGTND(IFLAG))) * GO TO 50 C Check source IF ((FLGSOU(IFLAG).NE.SOURID) .AND. (FLGSOU(IFLAG).NE.0) .AND. * (SOURID.NE.0)) GO TO 50 C Check antenna FLGA = FLGANT(IFLAG) IF ((FLGA.NE.0) .AND. (FLGA.NE.ANTNO)) GO TO 50 C Check subarray IF ((FLGSUB(IFLAG).GT.0) .AND. (FLGSUB(IFLAG).NE.SUBA)) * GO TO 50 C Check freqid.: may be changed C from input to 1 already IF ((FLGFQD(IFLAG).GT.0) .AND. (FLGFQD(IFLAG).NE.FREQID) .AND. * (FREQID.GT.0)) GO TO 50 C Some data to be flagged C Set limits LIMF1 = FLGBIF(IFLAG) LIMF2 = FLGEIF(IFLAG) C Loop over polarizations IPOLPT = ABS(KCOR0) - 1 IF (KCOR0.LT.-4) IPOLPT = IPOLPT - 4 DO 40 JPOLN = 1,NPOL IF (FLGPOL(JPOLN+IPOLPT,IFLAG)) THEN C Loop over IF DO 30 JIF = LIMF1,LIMF2 TSYS(JPOLN,JIF) = FBLANK TANT(JPOLN,JIF) = FBLANK 30 CONTINUE END IF 40 CONTINUE 50 CONTINUE C Check if data all DO 70 JPOLN = 1,NPOL DO 60 JIF = 1,NIF IF ((TSYS(JPOLN,JIF).NE.FBLANK) .OR. * (TANT(JPOLN,JIF).NE.FBLANK)) GO TO 999 60 CONTINUE 70 CONTINUE IRET = -1 C 999 RETURN END SUBROUTINE SNFSEL (DISKI, CNOI, DISKO, CNOO, VER, CATIN, CATOUT, * LUNI, LUNO, BPOL, EPOL, BIF, EIF, IFQID, TB, TE, ISUB, JSUB, * BUFFER, OBUFF, IRET) C----------------------------------------------------------------------- C Copies a subset of IFs in a SN table, can also modify the FQ ID C Applies flagging as well C Inputs: C DISKI I Input volume number C CNOI I Input catalog number C DISKO I Output volume number C CNOO I Output catalog number C VER I Version to check/modify C CATIN(256) I Input catalog header C CATOUT(256) I Output catalog header C LUNI I LUN to use C LUNO I LUN to use C BIF I Start IF number C EIF I End IF number C IFQID I FQ ID to select (output value is 1) C if <= 0 then output value unchanged. C TB D Beginning time in days C TE D Ending time in days C ISUB I Selected subarray (= 0 any) C JSUB I Output subarray number (< 0 => NO CHANGE) C Input/Output: C BUFFER I(*) Work buffer C OBUFF I(*) Work buffer C Output: C IRET I Error, 0 => OK C----------------------------------------------------------------------- INTEGER DISKI, CNOI, DISKO, CNOO, VER, CATIN(256), CATOUT(256), * LUNI, LUNO, BPOL, EPOL, BIF, EIF, IFQID, ISUB, JSUB, BUFFER(*), * OBUFF(*), IRET DOUBLE PRECISION TB, TE C INCLUDE 'INCS:PUVD.INC' INTEGER ISNRNO, SNKOLS(MAXSNC), SNNUMV(MAXSNC), NUMANT, NUMPOL, * NUMIF, NUMNOD, OKOLS(MAXSNC), ONUMV(MAXSNC), NSNROW, I, OVER, * SOURID, ANTNO, SUBA, FREQID, NODENO, REFA(2,MAXIF), OSNRNO, * NEWNIF, IIF, JIF, IPOL, NDEL, NTOT, JRET, LBPOL, NEWPOL, K, * LBIF LOGICAL ISAPPL, REFMT, GOTONE REAL GMMOD, RANOD(25), DECNOD(25), TIMEI, IFR, MBDELY(2), * CREAL(2,MAXIF), CIMAG(2,MAXIF), DELAY(2,MAXIF), RATE(2,MAXIF), * WEIGHT(2,MAXIF), DISP(2), DDISP(2) DOUBLE PRECISION TIME INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:PFLG.INC' INCLUDE 'INCS:DFLG.INC' C----------------------------------------------------------------------- C open flag table TMFLST = -1.E20 NUMFLG = 0 IFGRNO = 1 NDEL = 0 NTOT = 0 C Open SN file CALL SNINI ('READ', BUFFER, DISKI, CNOI, VER, CATIN, LUNI, * ISNRNO, SNKOLS, SNNUMV, NUMANT, NUMPOL, NUMIF, NUMNOD, * GMMOD, RANOD, DECNOD, ISAPPL, IRET) IF (IRET.EQ.2) THEN IRET = 0 GO TO 999 END IF IF (IRET.NE.0) THEN WRITE (MSGTXT,1010) IRET GO TO 990 END IF C New no. of IFs LBIF = MAX (1, BIF) NEWNIF = MIN (NUMIF, EIF) - BIF + 1 IF (NEWNIF.LE.0) THEN NEWNIF = NUMIF LBIF = 1 END IF LBPOL = MAX (1, BPOL) NEWPOL = MIN (2, MIN (NUMPOL, EPOL)) - LBPOL + 1 IF (NEWPOL.LE.0) THEN NEWPOL = NUMPOL LBPOL = 1 END IF REFMT = (NEWNIF.NE.NUMIF) .OR. (NEWPOL.NE.NUMPOL) C # rows in old table NSNROW = BUFFER(5) C Open up new SN table OVER = VER CALL SNINI ('WRIT', OBUFF, DISKO, CNOO, OVER, CATOUT, LUNO, * OSNRNO, OKOLS, ONUMV, NUMANT, NEWPOL, NEWNIF, NUMNOD, * GMMOD, RANOD, DECNOD, ISAPPL, IRET) IF (IRET.GT.0) THEN WRITE (MSGTXT,1010) IRET GO TO 990 END IF C Loop and copy DO 100 I = 1,NSNROW CALL TABSN ('READ', BUFFER, ISNRNO, SNKOLS, SNNUMV, NUMPOL, * TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, NODENO, * MBDELY, DISP, DDISP, CREAL, CIMAG, DELAY, RATE, WEIGHT, * REFA, IRET) C check subarray and FQ IF (IRET.EQ.0) THEN CALL SNFLG (NUMPOL, NUMIF, TIME, SOURID, ANTNO, SUBA, * FREQID, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, JRET) IF (JRET.GT.0) THEN IRET = JRET GO TO 999 END IF IF ((SUBA.GT.0) .AND. (ISUB.GT.0) .AND. (ISUB.NE.SUBA)) * IRET = -1 IF ((IFQID.GT.0) .AND. (FREQID.GT.0) .AND. * (IFQID.NE.FREQID)) IRET = -1 IF ((TIME.LT.TB) .OR. (TIME.GT.TE)) IRET = -1 IF ((JRET.EQ.-1) .AND. (IRET.EQ.0)) THEN IRET = -1 NDEL = NDEL + 1 END IF END IF C Is this record selected ? IF ((IRET.LT.0) .OR. (NEWNIF.EQ.0)) THEN REFMT = .TRUE. C Error reading table ELSE IF (IRET.GT.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 C Select IFs ELSE GOTONE = .FALSE. DO 90 JIF = 1,NEWNIF IIF = JIF + LBIF - 1 DO 80 IPOL = 1,NEWPOL K = IPOL + LBPOL - 1 CREAL(IPOL,JIF) = CREAL(K,IIF) CIMAG(IPOL,JIF) = CIMAG(K,IIF) DELAY(IPOL,JIF) = DELAY(K,IIF) RATE(IPOL,JIF) = RATE(K,IIF) WEIGHT(IPOL,JIF) = WEIGHT(K,IIF) REFA(IPOL,JIF) = REFA(K,IIF) IF (CREAL(IPOL,JIF).NE.FBLANK) GOTONE = .TRUE. 80 CONTINUE 90 CONTINUE C Write new one IF (GOTONE) THEN IF (IFQID.GT.0) FREQID = 1 IF (JSUB.GE.0) SUBA = JSUB NTOT = NTOT + 1 CALL TABSN ('WRIT', OBUFF, OSNRNO, OKOLS, ONUMV, NEWPOL, * TIME, TIMEI, SOURID, ANTNO, SUBA, FREQID, IFR, NODENO, * MBDELY, DISP, DDISP, CREAL, CIMAG, DELAY, RATE, * WEIGHT, REFA, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 END IF ELSE REFMT = .TRUE. END IF END IF 100 CONTINUE IRET = 0 C Close both tables CALL TABIO ('CLOS', 0, ISNRNO, BUFFER, BUFFER, IRET) CALL TABIO ('CLOS', 0, OSNRNO, OBUFF, OBUFF, IRET) IF ((MSGSUP.LT.31990) .OR. (MSGSUP.GE.32000)) THEN IF (REFMT) THEN WRITE (MSGTXT,1100) 'Reformatted SN', DISKI, CNOI, VER, * DISKO, CNOO, OVER ELSE WRITE (MSGTXT,1100) 'Copied SN', DISKI, CNOI, VER, DISKO, * CNOO, OVER END IF CALL MSGWRT (3) NTOT = NTOT + NDEL WRITE (MSGTXT,1101) NDEL, NTOT CALL REFRMT (MSGTXT, '_', I) CALL MSGWRT (3) END IF GO TO 999 C Error 990 CALL MSGWRT (6) C 999 RETURN C----------------------------------------------------------------------- 1010 FORMAT ('SNSEL: ERROR ',I3,' RETURNED FROM SNINI') 1020 FORMAT ('SNSEL: ERROR ',I3,' RETURNED FROM TABSN') 1100 FORMAT (A,' file from vol/cno/vers',I3,I5,I4,' to',I3,I5,I4) 1101 FORMAT ('__Fully deleted',I10,' of',I12,' SN records applying', * ' flag table') END SUBROUTINE SNFLG (NPOL, NIF, TIME, SOURID, ANTNO, SUBA, * FREQID, CREAL, CIMAG, DELAY, RATE, WEIGHT, REFA, IRET) C----------------------------------------------------------------------- C Flags a SN table row based on the flags in FG table loaded to Common C Inputs: C NPOL I Number polarizations in TY data C NIF I Number of IFs in those data C TIME D Time of table row C SOURID I Source number of row C ANTNO I Antenna number of row C SUBA I Subarray of row C FREQID I Frequency ID if row C In/Out: C CREAL R(2,*) Real part of solution C CIMAG R(2,*) Imaginary part of solution C DELAY R(2,*) Delay C RATE R(2,*) Rate C WEIGHT R(2,*) Solution weight C REFA I(2,*) Reference antenna C Inputs from include DSEL.INC: C NUMFLG I Number of flagging entries. C TMFLST R Time of last visibility for which flagging C was checked. C FLGSOU(*) I Source id numbers to flag, 0=all. C FLGANT(*) I Antenna numbers to flag, 0=all. C FLGBAS(*) I Baseline (A1*32768+A2) numbers to flag, 0=all. C FLGSUB(*) I Subarray numbers to flag, 0=all. C FLGFQD(*) I Freqid numbers to flag, <=0=all. C Following should have defaults filled in. C FLGBIF(*) I First IF to flag. C FLGEIF(*) I Highest IF to flag. C FLGBCH(*) I First channel to flag. C FLGECH(*) I Highest channel to flag. C FLGPOL(4,*)L Flags for the polarizations, should correspond C to selected polarization types. C Output: C IRET I 0 -> okay, -1 -> all flagged C----------------------------------------------------------------------- DOUBLE PRECISION TIME INTEGER NPOL, NIF, SOURID, ANTNO, SUBA, FREQID, REFA(2,*), IRET REAL CREAL(2,*), CIMAG(2,*), DELAY(2,*), RATE(2,*), * WEIGHT(2,*) C INTEGER IFLAG, FLGA, JPOLN, JIF, LIMF1, LIMF2, IPOLPT REAL RTIME INCLUDE 'INCS:PUVD.INC' INCLUDE 'INCS:PFLG.INC' INCLUDE 'INCS:DFLG.INC' INCLUDE 'INCS:DDCH.INC' C----------------------------------------------------------------------- IRET = 0 RTIME = TIME IF (TMFLST.LT.TIME) CALL NXTFLG (RTIME, .TRUE., IRET) IF (IRET.NE.0) GO TO 999 IF (NUMFLG.LE.0) GO TO 999 C loop over current flags DO 50 IFLAG = 1,NUMFLG C Check time if needed IF ((TIME.LT.FLGTST(IFLAG)) .OR. (TIME.GT.FLGTND(IFLAG))) * GO TO 50 C Check source IF ((FLGSOU(IFLAG).NE.SOURID) .AND. (FLGSOU(IFLAG).NE.0) .AND. * (SOURID.NE.0)) GO TO 50 C Check antenna FLGA = FLGANT(IFLAG) IF ((FLGA.NE.0) .AND. (FLGA.NE.ANTNO)) GO TO 50 C Check subarray IF ((FLGSUB(IFLAG).GT.0) .AND. (FLGSUB(IFLAG).NE.SUBA)) * GO TO 50 C Check freqid.: may be changed C from input to 1 already IF ((FLGFQD(IFLAG).GT.0) .AND. (FLGFQD(IFLAG).NE.FREQID) .AND. * (FREQID.GT.0)) GO TO 50 C Some data to be flagged C Set limits LIMF1 = FLGBIF(IFLAG) LIMF2 = FLGEIF(IFLAG) C Loop over polarizations IPOLPT = ABS(KCOR0) - 1 IF (KCOR0.LT.-4) IPOLPT = IPOLPT - 4 DO 40 JPOLN = 1,NPOL IF (FLGPOL(JPOLN+IPOLPT,IFLAG)) THEN C Loop over IF DO 30 JIF = LIMF1,LIMF2 CREAL(JPOLN,JIF) = FBLANK CIMAG(JPOLN,JIF) = FBLANK DELAY(JPOLN,JIF) = FBLANK RATE(JPOLN,JIF) = FBLANK WEIGHT(JPOLN,JIF) = 0.0 REFA(JPOLN,JIF) = 0 30 CONTINUE END IF 40 CONTINUE 50 CONTINUE C Check if data all gone DO 70 JPOLN = 1,NPOL DO 60 JIF = 1,NIF IF ((CREAL(JPOLN,JIF).NE.FBLANK) .AND. * (CIMAG(JPOLN,JIF).NE.FBLANK)) GO TO 999 60 CONTINUE 70 CONTINUE IRET = -1 C 999 RETURN END SUBROUTINE SYFSEL (DISKI, CNOI, DISKO, CNOO, VER, CATIN, CATOUT, * LUNI, LUNO, BPOL, EPOL, BIF, EIF, IFQID, TB, TE, NSOU, SOUIND, * AN, NA, ISUB, JSUB, BUFFER, OBUFF, IRET) C----------------------------------------------------------------------- C Copies a subset of IFs in a SY table, can also modify the FQ ID C Inputs: C DISKI I Input volume number C CNOI I Input catalog number C DISKO I Output volume number C CNOO I Output catalog number C VER I Version to check/modify C CATIN I(256) Input catalog header C CATOUT I(256) Output catalog header C LUNI I LUN to use C LUNO I LUN to use C BPOL I First polarization to copy C EPOL I Last polarization to copy C BIF I Start IF number C EIF I End IF number C IFQID I FQ ID to select (set to 1 on output) C if <= 0 then output value unchanged. C TB D Beginning time in days C TE D Ending time in days C NSOU I Number of selected sources C SOUIND I(*) Array of sources indexes selected C AN I(*) Array of selected antennas C NA I Number of selected antennas C ISUB I Selected subarray (= 0 any) C JSUB I Output subarray number (< 0 => NO CHANGE) C Input/Output: C BUFFER I(*) Work buffer C OBUFF I(*) Work buffer C Output: C IRET I Error, 0 => OK C----------------------------------------------------------------------- INTEGER DISKI, CNOI, DISKO, CNOO, VER, CATIN(256), CATOUT(256), * LUNI, LUNO, BPOL, EPOL, BIF, EIF, IFQID, AN(*), NA, SOUIND(*), * NSOU, ISUB, JSUB, BUFFER(*), OBUFF(*), IRET DOUBLE PRECISION TB, TE C INCLUDE 'INCS:PUVD.INC' INTEGER ISYRNO, SYKOLS(MAXSYC), SYNUMV(MAXSYC), NUMANT, NUMPOL, * NUMIF, OKOLS(MAXSYC), ONUMV(MAXSYC), NSYROW, I, SOURID, ANTNO, * SUBA, FREQID, OSYRNO, NEWNIF, IIF, JIF, IPOL, K, OVER, LBIF, * NEWPOL, LBPOL, NDEL, NTOT, JRET, NPART, CALTYP REAL PDIFF(2,MAXIF), PSUM(2,MAXIF), PGAIN(2,MAXIF), TIMEI DOUBLE PRECISION TIME LOGICAL GOTIT, REFMT, GOTONE INCLUDE 'INCS:DMSG.INC' INCLUDE 'INCS:DDCH.INC' INCLUDE 'INCS:DHDR.INC' INCLUDE 'INCS:PFLG.INC' INCLUDE 'INCS:DFLG.INC' C----------------------------------------------------------------------- C open flag table TMFLST = -1.E20 NUMFLG = 0 IFGRNO = 1 NDEL = 0 NTOT = 0 NPART = 0 C Open SY file CALL SYINI ('READ', BUFFER, DISKI, CNOI, VER, CATIN, LUNI, ISYRNO, * SYKOLS, SYNUMV, NUMANT, NUMPOL, NUMIF, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1010) IRET GO TO 990 END IF C New no. of IF's LBIF = MAX (1, BIF) NEWNIF = MIN (NUMIF, EIF) - LBIF + 1 IF (NEWNIF.LE.0) THEN LBIF = 1 NEWNIF = NUMIF END IF LBPOL = MAX (1, BPOL) NEWPOL = MIN (2, MIN (NUMPOL, EPOL)) - LBPOL + 1 IF (NEWPOL.LE.0) THEN NEWPOL = NUMPOL LBPOL = 1 END IF REFMT = (NEWNIF.NE.NUMIF) .OR. (NEWPOL.NE.NUMPOL) C # rows in old table NSYROW = BUFFER(5) C Open up new SY table OVER = VER CALL SYINI ('WRIT', OBUFF, DISKO, CNOO, OVER, CATOUT, LUNO, * OSYRNO, OKOLS, ONUMV, NUMANT, NEWPOL, NEWNIF, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1020) IRET GO TO 990 END IF C Loop and copy DO 100 I = 1,NSYROW CALL TABSY ('READ', BUFFER, ISYRNO, SYKOLS, SYNUMV, NUMPOL, * NUMIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA, FREQID, * PDIFF, PSUM, PGAIN, IRET) IF (IRET.GT.0) THEN WRITE (MSGTXT,1030) IRET GO TO 990 END IF C flag info CALL SYFLG (NUMPOL, NUMIF, TIME, SOURID, ANTNO, SUBA, FREQID, * PDIFF, PSUM, PGAIN, NPART, JRET) IF (JRET.GT.0) THEN IRET = JRET GO TO 999 END IF C Time selection IF ((TIME.LT.TB) .OR. (TIME.GT.TE)) IRET = -1 C Sources selection IF ((NSOU.GT.0) .AND. (SOURID.GT.0)) THEN GOTIT = .FALSE. DO 20 K = 1,NSOU GOTIT = GOTIT .OR. (SOURID.EQ.SOUIND(K)) 20 CONTINUE IF (.NOT.GOTIT) IRET = -1 END IF C Antennas selection IF ((NA.GT.0) .AND. (ANTNO.GT.0)) THEN GOTIT = .FALSE. DO 30 K = 1,NA GOTIT = GOTIT .OR. (ANTNO.EQ.AN(K)) 30 CONTINUE IF (.NOT.GOTIT) IRET = -1 END IF C FQ selection IF ((IFQID.GT.0) .AND. (FREQID.GT.0) .AND. (IFQID.NE.FREQID)) * IRET = -1 C Suba selection IF ((SUBA.GT.0) .AND. (ISUB.GT.0) .AND. (ISUB.NE.SUBA)) * IRET = -1 IF ((JRET.EQ.-1) .AND. (IRET.EQ.0)) THEN IRET = -1 NDEL = NDEL + 1 END IF C Is this record selected ? IF (IRET.LT.0) THEN REFMT = .TRUE. C Re-number IF's ELSE GOTONE = .FALSE. DO 90 JIF = 1,NEWNIF IIF = JIF + BIF - 1 DO 80 IPOL = 1,NEWPOL K = IPOL + LBPOL - 1 PDIFF(IPOL,JIF) = PDIFF(K,IIF) PSUM(IPOL,JIF) = PSUM(K,IIF) PGAIN(IPOL,JIF) = PGAIN(K,IIF) IF (PDIFF(IPOL,JIF).NE.FBLANK) GOTONE = .TRUE. IF (PSUM(IPOL,JIF).NE.FBLANK) GOTONE = .TRUE. 80 CONTINUE 90 CONTINUE IF (GOTONE) THEN IF (IFQID.GT.0) FREQID = 1 IF (JSUB.GE.0) SUBA = JSUB NTOT = NTOT + 1 CALL TABSY ('WRIT', OBUFF, OSYRNO, OKOLS, ONUMV, NEWPOL, * NEWNIF, TIME, TIMEI, CALTYP, SOURID, ANTNO, SUBA, * FREQID, PDIFF, PSUM, PGAIN, IRET) IF (IRET.NE.0) THEN WRITE (MSGTXT,1040) IRET GO TO 990 END IF ELSE REFMT = .TRUE. END IF END IF 100 CONTINUE IRET = 0 C Close both tables CALL TABIO ('CLOS', 0, ISYRNO, BUFFER, BUFFER, IRET) CALL TABIO ('CLOS', 0, OSYRNO, OBUFF, OBUFF, IRET) IF ((MSGSUP.LT.31990) .OR. (MSGSUP.GE.32000)) THEN IF (REFMT) THEN WRITE (MSGTXT,1100) 'Reformatted SY', DISKI, CNOI, VER, * DISKO, CNOO, OVER ELSE WRITE (MSGTXT,1100) 'Copied SY', DISKI, CNOI, VER, DISKO, * CNOO, OVER END IF CALL MSGWRT (3) NTOT = NTOT + NDEL WRITE (MSGTXT,1101) NDEL, NTOT CALL REFRMT (MSGTXT, '_', I) CALL MSGWRT (3) WRITE (MSGTXT,1102) NPART CALL REFRMT (MSGTXT, '_', I) IF (NPART.GT.0) CALL MSGWRT (3) END IF GO TO 999 C Error 990 CALL MSGWRT (6) C 999 RETURN C----------------------------------------------------------------------- 1010 FORMAT ('SYFSEL: ERROR ',I3,' INITING OLD TABLE') 1020 FORMAT ('SYFSEL: ERROR ',I3,' INITING NEW TABLE') 1030 FORMAT ('SYFSEL: ERROR ',I3,' READING OLD TABLE') 1040 FORMAT ('SYFSEL: ERROR ',I3,' WRITING NEW TABLE') 1100 FORMAT (A,' file from vol/cno/vers',I3,I5,I4,' to',I3,I5,I4) 1101 FORMAT ('__Fully deleted',I10,' of',I12,' SY records applying', * ' flag table') 1102 FORMAT ('__Partly flagged',I10,' SY records applying flag table') END SUBROUTINE SYFLG (NPOL, NIF, TIME, SOURID, ANTNO, SUBA, * FREQID, PDIFF, PSUM, PGAIN, NPART, IRET) C----------------------------------------------------------------------- C Flags a TY table row based on the flags in FG table loaded to Common C Inputs: C NPOL I Number polarizations in TY data C NIF I Number of IFs in those data C TIME R Time of table row C SOURID I Source number of row C ANTNO I Antenna number of row C SUBA I Subarray of row C FREQID I Frequency ID if row C In/Out: C PDIFF R(*) Pon-Poff C PSUM R(*) Pon+Poff C PGAIN R(*) Post detection gains C NPART I count of partly flagged records C Inputs from include DSEL.INC: C NUMFLG I Number of flagging entries. C TMFLST R Time of last visibility for which flagging C was checked. C FLGSOU(*) I Source id numbers to flag, 0=all. C FLGANT(*) I Antenna numbers to flag, 0=all. C FLGBAS(*) I Baseline (A1*32768+A2) numbers to flag, 0=all. C FLGSUB(*) I Subarray numbers to flag, 0=all. C FLGFQD(*) I Freqid numbers to flag, <=0=all. C Following should have defaults filled in. C FLGBIF(*) I First IF to flag. C FLGEIF(*) I Highest IF to flag. C FLGBCH(*) I First channel to flag. C FLGECH(*) I Highest channel to flag. C FLGPOL(4,*)L Flags for the polarizations, should correspond C to selected polarization types. C Output: C IRET I 0 -> okay, -1 -> all flagged C----------------------------------------------------------------------- INTEGER NPOL, NIF, SOURID, ANTNO, SUBA, FREQID, NPART, IRET REAL PDIFF(2,*), PSUM(2,*), PGAIN(2,*) DOUBLE PRECISION TIME C INTEGER IFLAG, FLGA, JPOLN, JIF, LIMF1, LIMF2, IPOLPT REAL RTIME LOGICAL PART INCLUDE 'INCS:PUVD.INC' INCLUDE 'INCS:PFLG.INC' INCLUDE 'INCS:DFLG.INC' INCLUDE 'INCS:DDCH.INC' C----------------------------------------------------------------------- IRET = 0 RTIME = TIME IF (TMFLST.LT.TIME) CALL NXTFLG (RTIME, .TRUE., IRET) IF (IRET.NE.0) GO TO 999 IF (NUMFLG.LE.0) GO TO 999 PART = .FALSE. C loop over current flags DO 50 IFLAG = 1,NUMFLG C Check time if needed IF ((TIME.LT.FLGTST(IFLAG)) .OR. (TIME.GT.FLGTND(IFLAG))) * GO TO 50 C Check source IF ((FLGSOU(IFLAG).NE.SOURID) .AND. (FLGSOU(IFLAG).NE.0) .AND. * (SOURID.NE.0)) GO TO 50 C Check antenna FLGA = FLGANT(IFLAG) IF ((FLGA.NE.0) .AND. (FLGA.NE.ANTNO)) GO TO 50 C Check subarray IF ((FLGSUB(IFLAG).GT.0) .AND. (FLGSUB(IFLAG).NE.SUBA)) * GO TO 50 C Check freqid.: may be changed C from input to 1 already IF ((FLGFQD(IFLAG).GT.0) .AND. (FLGFQD(IFLAG).NE.FREQID) .AND. * (FREQID.GT.0)) GO TO 50 C Some data to be flagged C Set limits LIMF1 = FLGBIF(IFLAG) LIMF2 = FLGEIF(IFLAG) C Loop over polarizations IPOLPT = ABS(KCOR0) - 1 IF (KCOR0.LT.-4) IPOLPT = IPOLPT - 4 DO 40 JPOLN = 1,NPOL IF (FLGPOL(JPOLN+IPOLPT,IFLAG)) THEN PART = .TRUE. C Loop over IF DO 30 JIF = LIMF1,LIMF2 PDIFF(JPOLN,JIF) = FBLANK PSUM(JPOLN,JIF) = FBLANK PGAIN(JPOLN,JIF) = FBLANK 30 CONTINUE END IF 40 CONTINUE 50 CONTINUE C Check if data all flagged IF (PART) NPART = NPART + 1 DO 70 JPOLN = 1,NPOL DO 60 JIF = 1,NIF IF ((PDIFF(JPOLN,JIF).NE.FBLANK) .OR. * (PSUM(JPOLN,JIF).NE.FBLANK)) GO TO 999 60 CONTINUE 70 CONTINUE IF (PART) NPART = NPART - 1 IRET = -1 C 999 RETURN END