C @(#)edistif.for	19.1 (ES0-DMD) 02/25/03 13:27:32
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
C.IDENTIFICATION
C
C  Program EDIST
C
C.AUTHOR
C
C  F. Murtagh, ST-ECF, Garching.             Version 1.0  9 May 1986
C  F. Murtagh                                Version 2.0  Oct. 1988
C
C.PURPOSE
C
C  Determine interrow distances (standardized).
C
C.INPUT/OUTPUT
C
C  P1 - P2 contain parameters; these are: input table name, output
C  table name.
C
C.ALGORITHM
C
C . uses Midas Table interface routines;
C . input table is assumed to contain entries in single precision;
C . no select or null values 
C . all columns of the input table are sent to the DIST routine;
C . description of the DIST routine is in the corresponding program;
C . storage is limited only by the Midas Table system, and by the
C   overall system limitations;
C
C.MODIFICATIONS
C
C  STANDARD INTERFACES, F. MURTAGH, AUG. 88
C  New Table File System, M. Peron , SEP91
C
C-----------------------------------------------------------------------
        PROGRAM EDIST
C
        CHARACTER*60     NAMEIN, NAMEOUT
        CHARACTER*6     FORM
        CHARACTER*16    UNIT, LABEL, LABEL2
        INTEGER         MADRID, KUN, KNUL
        INTEGER         DTYPE,NACTV,ISTAT,TID1,NCOLIN,NROW
        INTEGER         NSORTC,NAC,NAR,IPTRIN,I,LEN
        INTEGER         NSEL,NTOT,INULL,IACTV,TID,IPTROUT
        INTEGER         IADD1,IADD2
        INCLUDE         'MID_INCLUDE:TABLES.INC/NOLIST'
        COMMON          /VMR/MADRID(1)
        INCLUDE         'MID_INCLUDE:TABLED.INC/NOLIST'
C
C
C ...   Assuming this is our first action ...
C
        CALL STSPRO('EDIST')
        DTYPE = D_R4_FORMAT
C
C ...   Get table name as a keyword passed in the command line.
C
        CALL STKRDC('P1',1,1,60,NACTV,NAMEIN,KUN,KNUL,ISTAT)
C
C ...   Read input table.
C
        CALL TBTOPN(NAMEIN,0,TID1,ISTAT)
        CALL TBIGET(TID1,NCOLIN,NROW,NSORTC,NAC,NAR,ISTAT)
        CALL TBCMAP(TID1,0,IPTRIN,ISTAT)
C
C ...   Some error checking on input.
C
        IF (NROW.LT.1.OR.NCOLIN.LT.1) THEN
           CALL STTPUT(' Nos. of rows/columns are less than 1.',ISTAT)
           CALL STTPUT(' What sort of a table is this ??',ISTAT)
           CALL STTPUT(' Aborting.',ISTAT)
           GOTO 9000
        ENDIF
C
        DO I = 1, NCOLIN
           CALL TBFGET(TID1,I,FORM,LEN,DTYPE,ISTAT)
           IF (DTYPE.NE.D_R4_FORMAT) THEN
              CALL STTPUT(' Illegal format:',ISTAT)
              CALL STTPUT(' Only R*4 column type allowed.',ISTAT)
              CALL STTPUT(' Aborting.',ISTAT)
              GOTO 9000
           ENDIF
        ENDDO
C
        CALL CHSEL(TID1,NROW,NSEL)
        IF (NSEL.NE.NROW) THEN
           CALL STTPUT(' Not all rows are SELECTed. ',ISTAT)
           CALL STTPUT(' In current implementation, MUST select all.',
     X                                                         ISTAT)
           CALL STTPUT(' Aborting.',ISTAT)
           GOTO 9000
        ENDIF
C
        CALL TBCMAP(TID1,1,IPTRIN,ISTAT)
        NTOT = NROW*NCOLIN
        CALL CHNULL(MADRID(IPTRIN),NTOT,INULL)
        IF (INULL.NE.0) THEN
           CALL STTPUT
     X     (' Null entries in the table are not allowed.',ISTAT)
           CALL STTPUT
     X     (' Use SELECT, and then construct another table.',
     X                                                    ISTAT)
           CALL STTPUT(' Aborting.',ISTAT)
           GOTO 9000
        ENDIF
C
C
C ...   Get the output table name.
C
        CALL STKRDC('P2',1,1,60,IACTV,NAMEOUT,KUN,KNUL,ISTAT)
C
C ...   Now create the output (distances) table.
C
        CALL TBTINI(NAMEOUT,F_TRANS,17,NROW,NROW,TID,ISTAT)
        FORM = 'G14.6'
        UNIT = ' '
C       (The messing around with LABEL2 which follows is so that
C       leading zeros in a column label appear as such, and not as
C       blanks.)
        LABEL = 'ROW00'
        LABEL2 = '10001'
        DO I = 1, NROW
           WRITE (LABEL2(1:5),100) I+10000
           LABEL(4:5) = LABEL2(4:5)
           CALL TBCINI(TID,DTYPE,1,FORM,UNIT,LABEL,NSORTC,ISTAT)
        ENDDO
  100   FORMAT(I5)
C
        CALL TBCMAP(TID,1,IPTROUT,ISTAT)
C
C ...   Allocate storage.
C
        CALL GETSTOR(NROW,IADD1)
        CALL GETSTOR(NROW,IADD2)
C
        CALL DIST(NROW,NCOLIN,MADRID(IPTRIN),MADRID(IPTROUT),
     X              MADRID(IADD1),MADRID(IADD2))
C
C ...   Finish up: write output file to disk, and release memory space.
C
        CALL RELSTOR(NROW,IADD1)
        CALL RELSTOR(NROW,IADD2)
C
        CALL TBTCLO(TID1,ISTAT)
C
        CALL TBIPUT(TID,NROW,NROW,ISTAT)
        CALL TBSINI(TID,ISTAT)
        CALL TBTCLO(TID,ISTAT)
C
 9000   CONTINUE
        CALL STSEPI
C
        END
C-------------------------------------------------------------------------
        SUBROUTINE CHNULL(X,NT,NULL)
C ...   Check if null values are present.
        INTEGER I,NULL,NT
        REAL*4  X(NT), TRNULL
        INTEGER TINULL
        DOUBLE PRECISION TDNULL
        CALL TBMNUL(TINULL,TRNULL,TDNULL)
        NULL = 0
        DO I = 1, NT
           IF (X(I).EQ.TRNULL) NULL = NULL + 1
           IF (NULL.GT.0) RETURN
        ENDDO
        RETURN
        END
C-------------------------------------------------------------------------
        SUBROUTINE GETSTOR(NVALS,IPTR)
C ...   Allocate storage space for NVALS real values.
        INTEGER NVALS,IPTR,ISTAT
        CALL TDMGET(4*NVALS, IPTR, ISTAT)
        RETURN
        END
C-------------------------------------------------------------------------
        SUBROUTINE RELSTOR(NVALS,IPTR)
C ...   Release storage space (already allocated) for NVALS real values.
        INTEGER NVALS,IPTR,ISTAT
        CALL TDMFRE(4*NVALS, IPTR, ISTAT)
        RETURN
        END
