* Last processed by NICE on 12-Jun-2000 15:51:00 * Customized for : IEEE, LINUX, UNIX, MOTIF, F77 SUBROUTINE SELECT(N_SOURCES,IMIN,IMAX,T_RA,T_DEC,T_FLUX, $T_BLOCK,N_GOOD,NUM) C---------------------------------------------------------------------- C PSC Determines source number for all sources in the specified range C matching the selection criteria. C---------------------------------------------------------------------- INTEGER N_SOURCES, IMIN, IMAX, N_GOOD REAL T_RA(N_SOURCES), T_DEC(N_SOURCES), T_FLUX(N_SOURCES,4) INTEGER T_BLOCK(N_SOURCES), NUM(*) * Global INCLUDE 'inc:errcod.inc' INCLUDE 'psc.inc' INCLUDE 'psccrit.inc' INCLUDE 'description.inc' * Local INTEGER I, J, JNID REAL RATIO, LUMINOSITY REAL*8 DRA,DDEC,DLII,DBII LOGICAL ERROR * Data INCLUDE 'inc:constant.inc' * * Check for one step errors at the ends of the interval... DO WHILE(T_RA(IMIN).LT.RMIN.AND.IMIN.LT.N_SOURCES) IMIN = IMIN+1 ENDDO DO WHILE (T_RA(IMAX).GT.RMAX.AND.IMAX.GT.1) IMAX = IMAX-1 ENDDO * Loop on sources DO I = IMIN, IMAX * First, check whatever can be checked on the table information. * If any one of the criteria is not matched, then skip the source and try the * next one. This is easier to program (and even to read...) with goto's. IF (CHECK_TABLE) THEN IF (CHECK_EQU) THEN * Declination. Right ascention is already correct. IF (T_DEC(I).LT.DMIN) GOTO 1 IF (T_DEC(I).GT.DMAX) GOTO 1 ENDIF * Flux ratio. Upper limits on fluxes are stored as negative values. IF (CHECK_RATIO) THEN RATIO = ABS(T_FLUX(I,FOR_RATIO1))/T_FLUX(I,FOR_RATIO2) IF (RATIO.LT.MIN_RATIO) GOTO 1 RATIO = T_FLUX(I,FOR_RATIO1)/ABS(T_FLUX(I,FOR_RATIO2)) IF (RATIO.GT.MAX_RATIO) GOTO 1 ENDIF * Flux at one wavelength IF (CHECK_FLUX) THEN IF (T_FLUX(I,NUM_FLUX).LT.MIN_FLUX) GOTO 1 ENDIF * Total flux check. Unit is solar luminosity at one kpc IF (CHECK_LUMINOSITY) THEN LUMINOSITY = 7.17*MAX(T_FLUX(I,1),0.) $ + 3.33*MAX(T_FLUX(I,2),0.) $ + 1.50*MAX(T_FLUX(I,3),0.) $ + 0.62*MAX(T_FLUX(I,4),0.) LUMINOSITY = 0.93 * LUMINOSITY IF (LUMINOSITY.LT.MIN_LUMINOSITY) GOTO 1 ENDIF * Position in non equatorial coordinates IF (CHECK_NSTDBOX) THEN IF (TYPEC.EQ.TYPE_GA) THEN * Not correct: should handle two ranges... * Could use a single precision version for improved efficiency DRA = T_RA(I) DDEC = T_DEC(I) CALL EQ1950_TO_GAL(DRA,DDEC,DLII,DBII,1) IF (DLII.LT.BOX(1)) GOTO 1 IF (DLII.GT.BOX(2)) GOTO 1 IF (DBII.LT.BOX(3)) GOTO 1 IF (DBII.GT.BOX(4)) GOTO 1 ELSE WRITE(6,*) 'F-PSC, Internal logic error: ', $ ' unsupported coordinate system.' CALL SYSEXI(FATALE) ENDIF ENDIF ENDIF * Additional checks on the full information IF (CHECK_FILE) THEN * Retrieve full information from disk or tape CALL READ_BLOCK(T_BLOCK(I),START_SOURCE,ERROR) IF (ERROR) GOTO 1 CALL READ_BLOCK(T_BLOCK(I)+1,END_SOURCE,ERROR) IF (ERROR) GOTO 1 IF (CHECK_QUAL) THEN DO J=1,4 IF (FQUAL(J).LT.WANTED_QUAL(J)) GOTO 1 ENDDO ENDIF IF (CHECK_IDENT) THEN * Try to find a match between the source ID type and one of the accepted types. DO J=1,MAXID IF (IDTYPE.EQ.WANTED_IDENT(J)) GOTO 2 ENDDO GOTO 1 2 CONTINUE ENDIF * IF (CHECK_LRS_2) THEN IF (LRS_TYPE.NE.LRSCHAR) GOTO 1 ELSEIF (CHECK_LRS_1) THEN IF (LRS_TYPE(1:1).NE.LRSCHAR(1:1)) GOTO 1 ELSEIF (CHECK_LRS_0) THEN IF (LRSCHAR(1:2).EQ.' ') GOTO 1 ENDIF * The identification information should be stored * to optimize tape movements. IF (CHECK_CATA) THEN * SUN compiler wants an I*4 for loop boundary JNID = NID DO J=1,JNID CALL READ_BLOCK(T_BLOCK(I)+J+1,IDENTIFICATION,ERROR) IF (CATNO.EQ.WANTED_CATA) GOTO 3 ENDDO GOTO 1 3 CONTINUE ENDIF ENDIF IF (LISTOUT) THEN IF (.NOT.CHECK_FILE) THEN CALL READ_BLOCK(T_BLOCK(I),START_SOURCE,ERROR) IF (ERROR) GOTO 1 CALL READ_BLOCK(T_BLOCK(I)+1,END_SOURCE,ERROR) IF (ERROR) GOTO 1 ENDIF CALL WRITE_SOURCE(ERROR) IF (ERROR) GOTO 1 * Loop on identifications JNID = NID DO J = 1, JNID CALL READ_BLOCK(T_BLOCK(I)+J+1,IDENTIFICATION,ERROR) CALL WRITE_IDENTIFICATION(ERROR) IF (ERROR) GOTO 1 ENDDO ENDIF N_GOOD = N_GOOD + 1 NUM(N_GOOD) = I 1 CONTINUE ENDDO * RETURN END C C+VMS c FUNCTION IS_A_TAPE(NAME) C---------------------------------------------------------------------- C PSC Determines if the file NAME is on a tape device C---------------------------------------------------------------------- c CHARACTER*(*) NAME c LOGICAL IS_A_TAPE * c INTEGER CHAN c CHARACTER*63 DEVNAM c INTEGER*2 ILEN,ITEM,SHORT(2),IOSB(2) c INTEGER*4 WORD,ADDR c EQUIVALENCE (SHORT(1),WORD),(SHORT(1),ILEN),(SHORT(2),ITEM) c INTEGER*4 LIST(13),ICLASS,FLAG c INTEGER LDEV, LENC * c INTEGER IER,SYS$ASSIGN,SYS$DASSGN,SYS$GETDVI * c INCLUDE '($devdef)' c INCLUDE '($ssdef)' c PARAMETER DC$_TAPE = '00000002'X c PARAMETER DVI$_DEVCLASS=4 c PARAMETER DVI$_DEVTYP=6 c PARAMETER DVI$_DEVNAM=32 * c IER = SYS$ASSIGN(NAME(1:LENC(NAME)),CHAN,,) c IF (.NOT.IER) THEN c IF (IER.EQ.SS$_IVDEVNAM .OR. IER.EQ.SS$_NOSUCHDEV) THEN c IS_A_TAPE = .FALSE. c RETURN c ENDIF c CALL SYS$EXIT(%VAL(IER)) c ENDIF * * Find device class c ILEN = 4 c ADDR = %LOC(ICLASS) c ITEM = DVI$_DEVCLASS c LIST(1) = WORD c LIST(2) = ADDR c LIST(3) = 0 c LIST(4) = 0 * c IER = SYS$GETDVI(,%VAL(CHAN),,LIST,IOSB,,,) c IF (.NOT.IER) THEN c IF (IER.EQ.SS$_IVDEVNAM) THEN c IS_A_TAPE = .FALSE. c RETURN c ENDIF c CALL SYS$EXIT(%VAL(IER)) c ENDIF c IF (ICLASS.NE.DC$_TAPE) THEN c IS_A_TAPE = .FALSE. c ELSE c IS_A_TAPE = .TRUE. c ENDIF c CALL SYS$DASSGN(CHAN) c END C-VMS C+UNIX FUNCTION IS_A_TAPE(NAME) C---------------------------------------------------------------------- C PSC Determines if the file NAME is on a tape device C---------------------------------------------------------------------- CHARACTER*(*) NAME LOGICAL IS_A_TAPE IS_A_TAPE = .FALSE. END C-UNIX