C @(#)fromod.for	19.1 (ES0-DMD) 02/25/03 13:24:27
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
