C @(#)usrinp.for 17.1.1.1 (ES0-DMD) 01/25/02 17:19:02 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 SUBROUTINE USRINP(A,N,TYPE,CHARST) C+++ C.PURPOSE: Decode a character string into integer or real array C.AUTHOR: J.P. Terlouw, Kapteynlab, Groningen C.COMMENTS: none C.VERSION: ?????? RHW implementation C.VERSION: 910115 RHW IMPLICIT NONE added C--- IMPLICIT NONE INTEGER NR8 PARAMETER (NR8=512) REAL A(NR8) INTEGER N CHARACTER TYPE CHARACTER CHARST(72) INTEGER MAXLP PARAMETER (MAXLP=10) C INTEGER IREAL, ILOOP INTEGER I, II INTEGER IPOS, ITYPE INTEGER IA, IIN INTEGER NREAL INTEGER NI, NLOOP INTEGER NCH, NREST INTEGER NWORD, INSERT INTEGER DOLOOP(2,MAXLP) INTEGER NEL REAL AA REAL B8(NR8) REAL INCR REAL LOW REAL RA REAL UPP LOGICAL LOOP,SEP,ERR CHARACTER B1(72) CHARACTER ATYPE(2),LPSYM EXTERNAL NEL C EQUIVALENCE (RA,IA,AA) DATA ATYPE/'R','I'/ C C *** ERR = .FALSE. ! error in do-loop LPSYM = ':' ! loop symbol NI = 0 ! initial number of used words for array IPOS = 0 ! starting for array pointer ITYPE = 1 ! default type is real DO 10 I = 1,72 B1(I) = ' ' 10 CONTINUE CALL ALPHA(CHARST,72,NCH,NREST) DO 20 II = 1,NCH B1(II) = CHARST(II) 20 CONTINUE DO 30 I = 1,2 IF (TYPE.EQ.ATYPE(I)) THEN ! what type? ITYPE = I END IF 30 CONTINUE C C *** GET INPUT PARAMETERS IF PRESENT C IF (NCH.NE.0) THEN ERR = .FALSE. ! reset error flag NLOOP = 0 IF ((ITYPE.EQ.1) .OR. (ITYPE.EQ.3)) THEN ! decode loop DO 40 I = 1,MAXLP DOLOOP(1,I) = 0 DOLOOP(2,I) = 0 40 CONTINUE NLOOP = 1 NWORD = 1 ! startword of do-loop in b1 INSERT = 0 LOOP = .FALSE. SEP = .TRUE. DO 50 I = 1,NCH IF (B1(I).EQ.LPSYM) THEN IF (B1(I-1).EQ.' ' .OR. B1(I+1).EQ.' ') THEN ! bad syntax ERR = .TRUE. GO TO 60 END IF IF (DOLOOP(2,NLOOP).EQ.1) THEN DOLOOP(2,NLOOP) = 2 ! increment value present INSERT = INSERT + 1 ELSE IF (DOLOOP(2,NLOOP).EQ.2) THEN ERR = .TRUE. ! error in do-loop input string NCH = 0 GO TO 60 ! back to inpu ELSE ! upper value present DOLOOP(1,NLOOP) = NWORD + INSERT DOLOOP(2,NLOOP) = 1 INSERT = INSERT + 1 END IF LOOP = .TRUE. B1(I) = ',' ELSE IF (B1(I).EQ.' ' .OR. B1(I).EQ.',') THEN ! sep. symbols IF ( .NOT. SEP) THEN NWORD = NWORD + 1 SEP = .TRUE. END IF C IF (LOOP) THEN NLOOP = NLOOP + 1 LOOP = .FALSE. END IF ELSE SEP = .FALSE. END IF END IF 50 CONTINUE C 60 CONTINUE IF ((.NOT.LOOP) .AND. (.NOT.ERR)) THEN NLOOP = NLOOP - 1 END IF END IF END IF C IF ((NCH.GT.0) .AND. (.NOT.ERR)) THEN ! decode input into real or char. CALL DECUSR(B1,NCH,B8,NR8) ! decodes input array into b8(nr8) NI = NEL(B8,NR8) ! actual number of words (=array elements) END IF C C *** CONSTRUCT THE OUTPUT ARRAY ************************************ C IPOS = 0 ! position in a ILOOP = 1 ! next loop (if present) IIN = 0 ! position in b8 IF (NI.GT.0) THEN 70 CONTINUE IIN = IIN + 1 RA = B8(IIN) IF (ITYPE.EQ.3) THEN ! real+integer conversion IA = NINT(RA) END IF IF (IPOS+1.LE.N) THEN ! conversion if ipos+1<# array el. A(IPOS+1) = RA END IF IPOS = IPOS + 1 ! increase position by one IF (IIN.EQ.DOLOOP(1,ILOOP)) THEN LOW = B8(IIN) IIN = IIN + 1 UPP = B8(IIN) IF (DOLOOP(2,ILOOP).EQ.1) THEN ! no increment was given INCR = 1. ELSE IIN = IIN + 1 INCR = B8(IIN) END IF AA = ((UPP-LOW)/INCR) ! # of reals to be added in A NREAL = ANINT(AA) IF (NREAL.GT.0) THEN DO 80 IREAL = 1,NREAL LOW = LOW + INCR RA = LOW IF (ITYPE.EQ.3) THEN ! real+integer conversion IA = NINT(RA) END IF IF (IPOS+1.LE.N) THEN ! conversion if ipos+1<# array el. A(IPOS+1) = RA END IF IPOS = IPOS + 1 ! increase position by one 80 CONTINUE END IF ILOOP = ILOOP + 1 END IF IF (IIN.LT.NI) GO TO 70 END IF C IF (IPOS.LT.N) THEN CALL SETEND(A(IPOS+1)) END IF RETURN END SUBROUTINE DECUSR(SS,L,ARRAY,NIN) C+++ C.PURPOSE: Subroutine to decode input string into a real array C.AUTHOR: J.P. Terlouw, Kapteynlab Groningen C.COMMENTS: none C.VERSION: 87???? RHW adjustments for and implementation in MIDAS C.VERSION: 910115 RHW IMPLICIT NONE added C--- IMPLICIT NONE INTEGER L ! IN: length of character string CHARACTER SS(L) ! IN: character string REAL ARRAY(50) ! OUT: real array INTEGER NIN ! OUT: length of the array C INTEGER IPOINT, IEPOW, ISIGN INTEGER I, II, IARR, IFMT INTEGER J INTEGER NOUT, N1 INTEGER LF, LD REAL ENDLN C CHARACTER FMT*150,SSS*150 LOGICAL REAL,EPOW,SIGN,CHAR,SEP 9000 FORMAT ('A',I1) 9010 FORMAT (I2.2,'X') 9020 FORMAT ('F',I2.2,'.',I2.2) C C *** start REAL = .FALSE. EPOW = .FALSE. SIGN = .FALSE. CHAR = .FALSE. SEP = .TRUE. IPOINT = 0 IEPOW = 0 ISIGN = 0 C DO 10 II = 1,L ! put ss(1 --> l) into sss(1:l) SSS(II:II) = SS(II) 10 CONTINUE DO 20 II = L + 1,150 SSS(II:II) = ' ' 20 CONTINUE C I = 1 ! index used for ss(1 ---> l) NOUT = 0 ! # of elements filled in array FMT(1:1) = '(' IFMT = 2 N1 = 1 ! first position of next field CALL SETEND(ENDLN) DO 30 IARR = 1,NIN ARRAY(IARR) = ENDLN 30 CONTINUE C 40 CONTINUE IF (I.LE.L .AND. NOUT.LT.NIN) THEN IF (SS(I).EQ.' ' .OR. SS(I).EQ.',' .OR. SS(I).EQ.':') THEN IF ( .NOT. SEP) THEN LF = I - N1 ! character string IF (CHAR) THEN LF = MIN(((NIN-NOUT)*1),LF) ! max space in array 50 CONTINUE IF (LF.GT.0) THEN WRITE (FMT(IFMT:IFMT+1),9000) MIN(1,LF) LF = LF - 1 IFMT = IFMT + 2 FMT(IFMT:IFMT) = ',' IFMT = IFMT + 1 NOUT = NOUT + 1 GO TO 50 END IF ELSE IF (IEPOW.EQ.0) THEN IEPOW = I END IF IF (IPOINT.EQ.0) THEN IPOINT = I END IF LD = MAX((IEPOW-IPOINT-1),0) WRITE (FMT(IFMT:IFMT+5),9020) LF,LD IFMT = IFMT + 6 FMT(IFMT:IFMT) = ',' IFMT = IFMT + 1 NOUT = NOUT + 1 END IF N1 = I C REAL = .FALSE. EPOW = .FALSE. SIGN = .FALSE. CHAR = .FALSE. SEP = .TRUE. IPOINT = 0 IEPOW = 0 ISIGN = 0 END IF ELSE IF (SEP) THEN LF = I - N1 IF (LF.GT.0) THEN WRITE (FMT(IFMT:IFMT+2),9010) LF IFMT = IFMT + 3 FMT(IFMT:IFMT) = ',' IFMT = IFMT + 1 END IF N1 = I C C *** input element is real IF (SS(I).GE.'0' .AND. SS(I).LE.'9' .OR. SS(I).EQ. + '+' .OR. SS(I).EQ.'-') THEN REAL = .TRUE. ELSE IF (SS(I).EQ.'.') THEN ! decimal point REAL = .TRUE. IPOINT = I ELSE CHAR = .TRUE. ! input element is character END IF END IF SEP = .FALSE. ELSE IF ( .NOT. CHAR) THEN IF (EPOW) THEN IF ( .NOT. SIGN) THEN IF (SS(I).EQ.'+' .OR. SS(I).EQ.'-') THEN ISIGN = 1 SIGN = .TRUE. ELSE IF (SS(I).GE.'0' .AND. SS(I).LE.'9') THEN SIGN = .TRUE. ELSE CHAR = .TRUE. END IF END IF ELSE IF (SS(I).LT.'0' .OR. SS(I).GT.'9' .OR. + ((IEPOW+ISIGN+2).LT.I)) THEN CHAR = .TRUE. END IF END IF ELSE IF (SS(I).EQ.'E') THEN EPOW = .TRUE. IEPOW = I ELSE IF (SS(I).EQ.'.') THEN IF (IPOINT.GT.0) THEN CHAR = .TRUE. ELSE IPOINT = I END IF ELSE IF (SS(I).LT.'0' .OR. SS(I).GT.'9') THEN CHAR = .TRUE. END IF END IF END IF END IF END IF END IF END IF I = I + 1 GO TO 40 END IF C IF (I.GT.N1) THEN IF ( .NOT. SEP) THEN LF = I - N1 IF (CHAR) THEN ! character string LF = MIN(((NIN-NOUT)*1),LF) ! max space in array 60 CONTINUE IF (LF.GT.0) THEN WRITE (FMT(IFMT:IFMT+1),9000) MIN(1,LF) LF = LF - 1 IFMT = IFMT + 2 FMT(IFMT:IFMT) = ',' IFMT = IFMT + 1 NOUT = NOUT + 1 GO TO 60 END IF ELSE IF (IEPOW.EQ.0) THEN IEPOW = I END IF IF (IPOINT.EQ.0) THEN IPOINT = I END IF LD = MAX((IEPOW-IPOINT-1),0) WRITE (FMT(IFMT:IFMT+5),9020) LF,LD IFMT = IFMT + 6 FMT(IFMT:IFMT) = ',' IFMT = IFMT + 1 NOUT = NOUT + 1 END IF N1 = I END IF END IF C FMT(IFMT-1:IFMT-1) = ')' IF (NOUT.GT.0) THEN READ (SSS(1:L),FMT=FMT(1:IFMT-1)) (ARRAY(J),J=1,NOUT) END IF C RETURN END INTEGER FUNCTION NEL(A,N) C+++ C.PURPOSE: Count the number of words in the input array of dimension C N by testing the array on -0 value C.AUTHOR: Rein H. Warmels C.COMMENTS: none C.VERSION: 890117 RHW Documented C.VERSION: 910115 RHW IMPLICIT NONE added C--- IMPLICIT NONE INTEGER N REAL A(N) C INTEGER I REAL END C DATA END/-32768/ C C *** DO 10 I = 1,N IF (A(I).EQ.END) THEN GO TO 20 END IF 10 CONTINUE 20 CONTINUE NEL = I - 1 RETURN END SUBROUTINE SETEND(X) C+++ C.PURPOSE: put an end of array word in X C.COMMENTS: none C.VERSION: 910115 RHW IMPLICIT NONE added C--- REAL X C REAL END DATA END/-32768/ C C *** X = END RETURN END SUBROUTINE ALPHA(A,LENGTH,NCHAR,NREST) C+++ C.PURPOSE: Alphanumeric handling routine C.AUTHOR: Rein H. Warmels C.COMMENTS: none C.VERSION: 87???? RHW creation C.VERSION: 910115 RHW IMPLICIT NONE added C--- IMPLICIT NONE CHARACTER*(*) A ! IN: input array of dimension n INTEGER LENGTH ! IN: max length of the character string INTEGER NCHAR ! OUT: number of actual characters INTEGER NREST ! OUT: number of remaining characters C CHARACTER X INTEGER I C C*** NCHAR = 0 DO 10 I = 1,LENGTH X = A(LENGTH-I+1:LENGTH-I+1) IF (X.NE.' ') THEN NCHAR = LENGTH + 1 - I NREST = LENGTH - NCHAR RETURN END IF 10 CONTINUE RETURN END