C @(#)fromod.for 17.1.1.1 (ES0-DMD) 01/25/02 17:14:43 C=========================================================================== C Copyright (C) 1995 European Southern Observatory (ESO) 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 Massachusetss Ave, Cambridge, C MA 02139, USA. C C Corresponding concerning ESO-MIDAS should be addressed as follows: C Internet e-mail: midas@eso.org C Postal address: European Southern Observatory C Data Management Division C Karl-Schwarzschild-Strasse 2 C D 85748 Garching bei Muenchen C GERMANY C=========================================================================== C C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ C.COPYRIGHT: Copyright (c) 1989 European Southern Observatory, C all rights reserved C.IDENTIFICATION: FROMOD C.PURPOSE: Part of ESOLV image retrieval software C.AUTHOR: J. Edwin Huizinga C.LANGUAGE: F77+ESOext C.KEYWORDS: ESOLV,optical-disk,retrieval C.ALGORITHM: C.INPUT/OUTPUT: C.VERSION: 890707 JEH creation C --------------------------------------------------------------------- PROGRAM FROMOD C C this program takes selected entries from INPUT TABLE and compares C them with the optical disk directory listings to see which C galaxies are on which disk. For each optical disk it outputs C a listing with selected entries in ESOMC2::ARCHIVE:[ESOLV]SELDLV?.LIS C These files can be used with COPYFROMOD.EXE C which extracts the selected galaxies from optical disk. C C declarations: C IMPLICIT NONE INTEGER MADRID INTEGER TID,IST,IAC,UNIT INTEGER NCOL,NROW,NSC,ACOL,AROW INTEGER I,J,K,ROW,COLNR INTEGER NWANT,WANTED(20) INTEGER B,ID INTEGER NGAL,COUNT,LABEL(15500) INTEGER IFATAL,KUN,INDF C LOGICAL FLAG,NOP C CHARACTER*1 MODE CHARACTER*80 TABLE,COLUMN CHARACTER*80 TEXT,DIRLINE CHARACTER*49 O_DISK_DIR CHARACTER*49 SEL_FILES CHARACTER*1 COLOUR CHARACTER*8 SELEC(15500),SORTED(15500),FIRST C INCLUDE 'MID_INCLUDE:ST_DEF.INC/NOLIST' COMMON /VMR/MADRID(1) INCLUDE 'MID_INCLUDE:ST_DAT.INC/NOLIST' C C ... initializations: DO I=1,15000 LABEL(I) = 0 ENDDO IFATAL = 0 C C ... init midas monitor: CALL STSPRO('FROMOD') C C ... get mode: CALL STKRDC('P1',1,1,20,IAC,MODE,UNIT,NOP,IST) CALL UPCAS(MODE,MODE) IF ((MODE.NE.'P').AND.(MODE.NE.'A')) THEN WRITE(TEXT,5) MODE 5 FORMAT('*** FATAL: not a valid mode: ',A1) CALL STTPUT(TEXT,IST) IFATAL = 1 CALL STKWRI('FATAL',IFATAL,1,1,KUN,IST) CALL STSEPI ENDIF C C ... get colour: CALL STKRDC('P2',1,1,1,IAC,COLOUR,UNIT,NOP,IST) CALL UPCAS(COLOUR,COLOUR) IF ((COLOUR.NE.'B').AND.(COLOUR.NE.'R').AND.(COLOUR.NE.'A')) THEN WRITE(TEXT,10) COLOUR 10 FORMAT('*** FATAL: not a valid colour: ',A1) CALL STTPUT(TEXT,IST) IFATAL = 1 CALL STKWRI('FATAL',IFATAL,1,1,KUN,IST) CALL STSEPI ENDIF C C if mode A then do things with table else with keywords IF (MODE.EQ.'A') THEN CALL STKRDC('P3',1,1,20,IAC,TABLE,UNIT,NOP,IST) CALL STKRDC('P4',1,1,20,IAC,COLUMN,UNIT,NOP,IST) CALL TBTOPN(TABLE,F_I_MODE,TID,IST) IF (IST.NE.0) THEN WRITE(TEXT,11) TABLE 11 FORMAT('*** FATAL: cannot open table ',A) IFATAL = 1 CALL STKWRI('FATAL',IFATAL,1,1,KUN,IST) CALL STTPUT(TEXT,IST) CALL STSEPI ENDIF CALL TBIGET(TID,NCOL,NROW,NSC,ACOL,AROW,IST) CALL TBCSER(TID,COLUMN,COLNR,IST) IF (IST.NE.0) THEN WRITE(TEXT,12) COLUMN 12 FORMAT('*** FATAL: problems finding column ',A20) IFATAL = 1 CALL STKWRI('FATAL',IFATAL,1,1,KUN,IST) CALL STTPUT(TEXT,IST) CALL TBTCLO(TID,IST) CALL STSEPI ENDIF C C ... find selected entries in TABLE and put them in SELEC C take care of COLOUR: A = both R and B images K = 0 DO ROW=1, NROW CALL TBSGET(TID,ROW,FLAG,IST) IF (FLAG) THEN CALL TBERDI(TID,ROW,COLNR,ID,NOP,IST) C C ... convert companions to main galaxy names: ID = ID - MOD(ID,10) C C ... use I7.7 format to get leading zeroes IF ((COLOUR.EQ.'A').OR.(COLOUR.EQ.'B')) THEN K = K + 1 SELEC(K)(1:1) = 'B' WRITE(SELEC(K)(2:8),17) ID 17 FORMAT(I7.7) ENDIF IF ((COLOUR.EQ.'A').OR.(COLOUR.EQ.'R')) THEN K = K + 1 SELEC(K)(1:1) = 'R' WRITE(SELEC(K)(2:8),17) ID ENDIF ENDIF ENDDO C C ... close TABLE: CALL TBTCLO(TID,IST) C C ... stop if no galaxies are selected at all: IF (K.EQ.0) THEN IFATAL = 1 CALL STKWRI('FATAL',IFATAL,1,1,KUN,IST) CALL STTPUT('*** FATAL: No selected entries',IST) CALL STSEPI ENDIF ELSE C C ... get eso-identifiers from keyword: CALL STKRDI('N',1,1,IAC,NWANT,UNIT,NOP,IST) IF (NWANT.EQ.0) THEN WRITE(TEXT,13) '*** FATAL: No ESO-identifiers given' 13 FORMAT(A) IFATAL = 1 CALL STKWRI('FATAL',IFATAL,1,1,KUN,IST) CALL STTPUT(TEXT,IST) CALL STSEPI ENDIF CALL STKRDI('INPUTI',1,NWANT,IAC,WANTED,UNIT,NOP,IST) K = 0 DO I=1, NWANT WANTED(I) = WANTED(I) - MOD(WANTED(I),10) C IF ((COLOUR.EQ.'A').OR.(COLOUR.EQ.'B')) THEN K = K + 1 SELEC(K)(1:1) = 'B' WRITE(SELEC(K)(2:8),17) WANTED(I) ENDIF IF ((COLOUR.EQ.'A').OR.(COLOUR.EQ.'R')) THEN K = K + 1 SELEC(K)(1:1) = 'R' WRITE(SELEC(K)(2:8),17) WANTED(I) ENDIF ENDDO ENDIF C C ... sort SELEC in alphabetical order and exclude doubles: NGAL = K DO I=1, K FIRST = 'YYYYYYYY' DO J=1, K IF (SELEC(J).LT.FIRST) THEN FIRST = SELEC(J) INDF = J ELSE IF (SELEC(J).EQ.FIRST) THEN SELEC(J) = 'ZZZZZZZZ' NGAL = NGAL-1 ENDIF ENDDO SORTED(I) = FIRST SELEC(INDF) = 'ZZZZZZZZ' ENDDO K = NGAL C C ... declare file identifiers, exact numbers will be filled in below: O_DISK_DIR(1:49) = 'ESOMC2"ESOLV MARTINI": +:ARCHIVE:[ESOLV]SORTLV?.LIS' SEL_FILES(1:49) = 'ESOMC2"ESOLV MARTINI": +:ARCHIVE:[ESOLV]SELDLV?.LIS' C C ... setup: DO I=1, 3 ! I = # OD_disk COUNT = 0 C C ... fill in exact file numbers: WRITE(O_DISK_DIR(45:45),20) I WRITE(SEL_FILES(45:45),20) I 20 FORMAT(I1) C C ... open existing optical disk number 'I' directory listing C and output file for galaxies found on this disk. OPEN(UNIT=12,FILE=O_DISK_DIR,STATUS='OLD') OPEN(UNIT=13,FILE=SEL_FILES,STATUS='NEW') C C ... init some counters and flags: B = 0 ! B=0 also next entry in listing else only in SELEC_FILES C C ... do it: READ(12,30) DIRLINE ! read first line away in listings 30 FORMAT(A) DO J = 1, NGAL IF (K.EQ.0) GOTO 999 ! all galaxies have been found IF (LABEL(J).NE.0) GOTO 888 ! if galaxy already found on other ! disk, skip it now. IF (B.EQ.1) GOTO 120 110 READ(12,30,END=999) DIRLINE B = 1 120 IF (DIRLINE(1:8).EQ.SORTED(J)(1:8)) THEN WRITE(13,30) DIRLINE LABEL(J) = I ! the disk number as label may be ! usefull later on. K = K - 1 COUNT = COUNT + 1 B = 0 ELSE IF (DIRLINE(1:8).LT.SORTED(J)(1:8)) GOTO 110 ENDIF 888 CONTINUE ENDDO 999 CONTINUE C C ... each time close used files, else there are to many open! CLOSE(12) CLOSE(13) WRITE(TEXT,40) I,COUNT 40 FORMAT(' Number of files found on ESOLV',I1,I6) CALL STTPUT(TEXT,IST) DO J=1,NGAL IF (LABEL(J).EQ.I) THEN WRITE(TEXT,45) SORTED(J) 45 FORMAT(' ',A) CALL STTPUT(TEXT,IST) ENDIF ENDDO C C ... goto next disk or finish up: ENDDO C C ... finished, now see how many galaxies were not found IF (K.NE.0) THEN WRITE(TEXT,50) K 50 FORMAT(' Number of galaxies not found:',I5) CALL STTPUT(TEXT,IST) DO I=1,NGAL IF (LABEL(I).EQ.0) THEN WRITE(TEXT,45) SORTED(I) CALL STTPUT(TEXT,IST) ENDIF ENDDO ENDIF C C ... if no galaxy found at all stop: IF (NGAL.EQ.K) THEN IFATAL = 1 CALL STKWRI('FATAL',IFATAL,1,1,KUN,IST) CALL STTPUT('*** I stop: No galaxies found',IST) CALL STSEPI ENDIF C C ... close midas monitor: CALL STSEPI END