C Utility routines C----------------------------------------------------------------------- C! Object Oriented FITSAIPS Fortran "Observing position" class library C# Map-util Utility Object-Oriented C----------------------------------------------------------------------- C; Copyright (C) 1995,1996,2001 C; Associated Universities, Inc. Washington DC, USA. 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 Massachusetts Ave, Cambridge, C; MA 02139, USA. C; C; Correspondence concerning FITSAIPS should be addressed as follows: C; Internet email: bcotton@nrao.edu. C; Postal address: Bill Cotton C; National Radio Astronomy Observatory C; 520 Edgemont Road C; Charlottesville, VA 22903-2475 USA C----------------------------------------------------------------------- C Various utility routines: C C Public functions: C XTRIM (instr, inlen, outstr, outlen) C Removes leading and trailing blanks, returns actual length of s C CTRIM (string) C Function to find last nonblank character in a string allowing a C "!" delimited comment. C COPY (n, kfrom, kto) C Copies integer words from one array to another C RFILL (n, c, a) C Fills an real array with an real constant C RCOPY (n, kfrom, kto) C Copies real words from one array to another C IROUND (x) C Function that rounds a REAL to the nearest INTEGER C C----------------------------------------------------------------------- C SUBROUTINE XTRIM (INSTR, INLEN, OUTSTR, OUTLEN) C----------------------------------------------------------------------- C XTRIM will trim leading and trailing blanks from an input string. C The output buffer can be the same as the input buffer. C Inputs: C INSTR C*(*) input string. C INLEN I length of string in characters C Outputs: C OUTSTR C*(*) buffer to hold resultant string. C It can be the same as INSTR. C OUTLEN I number of characters transfered to OUTSTR, C----------------------------------------------------------------------- CHARACTER INSTR*(*), OUTSTR*(*) INTEGER INLEN, OUTLEN C INTEGER I, IEND, ITRIM CHARACTER CTEMP*1024 C----------------------------------------------------------------------- C See if length OK. OUTLEN = 0 IF (INLEN.LE.0) GO TO 990 C Find number of trailing blanks. IEND = ITRIM (INSTR) C All blanks. IF (IEND.LE.0) GO TO 990 C Transfer all but leading & C trailing blanks. C CTEMP required if INSTR is same C as OUTSTR DO 10 I = 1,IEND IF (INSTR(I:I).NE.' ') THEN OUTLEN = IEND - I + 1 CTEMP = INSTR(I:IEND) OUTSTR = CTEMP GO TO 999 END IF 10 CONTINUE C 990 OUTSTR = ' ' C 999 RETURN END INTEGER FUNCTION CTRIM (STRING) C----------------------------------------------------------------------- C Function to determine length of the nonblank portion of a string C ignoring possible comments. Comments are delimited with "!" C Use with calls like: C TRIMMED = GROSS(1:CTRIM(GROSS)) C NOTE: this does not check for NULL characters C----------------------------------------------------------------------- CHARACTER STRING*(*) C INTEGER ITRIM, IT, IC C----------------------------------------------------------------------- IC = INDEX (STRING, '!') IF (IC.LE.0) IC = LEN(STRING) IF (IC.GT.1) IC = IC - 1 IT = ITRIM (STRING(1:IC)) CTRIM = MIN (IT, IC) C 999 RETURN END SUBROUTINE FILL (N, C, A) C----------------------------------------------------------------------- C fills an integer array with a constant C Inputs: C N I number of points to be filled in array C C I constant C Output: C A I(N) array C----------------------------------------------------------------------- INTEGER N, C, A(*) C INTEGER I C----------------------------------------------------------------------- IF (N.LE.0) GO TO 999 DO 10 I = 1,N A(I) = C 10 CONTINUE C 999 RETURN END SUBROUTINE COPY (N, KFROM, KTO) C----------------------------------------------------------------------- C COPY transfers N integer words from KFROM to KTO C Inputs: C N I number of words to be copied C KFROM I(N) input array C Outputs: C KTO I(N) output array C----------------------------------------------------------------------- INTEGER N, KFROM(*), KTO(*) C INTEGER I C----------------------------------------------------------------------- IF (N.LE.0) GO TO 999 DO 10 I = 1,N KTO(I) = KFROM(I) 10 CONTINUE C 999 RETURN END SUBROUTINE RFILL (N, C, A) C----------------------------------------------------------------------- C fills an REAL array with a constant C Inputs: C N I number of points to be filled in array C C R constant C Output: C A I(N) array C----------------------------------------------------------------------- INTEGER N REAL C, A(*) C INTEGER I C----------------------------------------------------------------------- IF (N.LE.0) GO TO 999 DO 10 I = 1,N A(I) = C 10 CONTINUE C 999 RETURN END SUBROUTINE RCOPY (N, KFROM, KTO) C----------------------------------------------------------------------- C COPY transfers N real words from KFROM to KTO C Inputs: C N I number of words to be copied C FROM R(N) input array C Outputs: C TO R(N) output array C----------------------------------------------------------------------- INTEGER N REAL KFROM(*), KTO(*) C INTEGER I C----------------------------------------------------------------------- IF (N.LE.0) GO TO 999 DO 10 I = 1,N KTO(I) = KFROM(I) 10 CONTINUE C 999 RETURN END INTEGER FUNCTION IROUND (X) C----------------------------------------------------------------------- C Round the real X to the nearest integer C----------------------------------------------------------------------- REAL X C----------------------------------------------------------------------- IF (X.GE.0.0) THEN IROUND = X + 0.500 ELSE IROUND = X - 0.500 END IF C 999 RETURN END