C @(#)edistif.for 17.1.1.1 (ES0-DMD) 01/25/02 17:16:49 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