C @(#)usrinp.for 13.1.1.1 (ES0-DMD) 06/02/98 18:30:08 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.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 C INTEGER NR8 PARAMETER (NR8=512) INTEGER MAXLP PARAMETER (MAXLP=10) C INTEGER IREAL, ILOOP INTEGER N, 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 C REAL A(NR8) REAL AA REAL B8(NR8) REAL INCR REAL LOW REAL RA REAL UPP C LOGICAL LOOP,SEP,ERR C CHARACTER TYPE CHARACTER CHARST(72) CHARACTER B1(72) CHARACTER ATYPE(2),LPSYM C EXTERNAL NEL C EQUIVALENCE (RA,IA,AA) C 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 C 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(*) ! 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 RREAL,EPOW,XSIGN,XCHAR,SEP C 9000 FORMAT ('A',I1) 9010 FORMAT (I2.2,'X') 9020 FORMAT ('F',I2.2,'.',I2.2) C C *** start RREAL = .FALSE. EPOW = .FALSE. XSIGN = .FALSE. XCHAR = .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 (XCHAR) THEN LF = MIN(((NIN-NOUT)*1),LF) ! max space in array 50 CONTINUE IF (LF.GT.0) THEN WRITE (FMT(IFMT:),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 RREAL = .FALSE. EPOW = .FALSE. XSIGN = .FALSE. XCHAR = .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 RREAL = .TRUE. ELSE IF (SS(I).EQ.'.') THEN ! decimal point RREAL = .TRUE. IPOINT = I ELSE XCHAR = .TRUE. ! input element is character END IF END IF SEP = .FALSE. ELSE IF ( .NOT. XCHAR) THEN IF (EPOW) THEN IF ( .NOT. XSIGN) THEN IF (SS(I).EQ.'+' .OR. SS(I).EQ.'-') THEN ISIGN = 1 XSIGN = .TRUE. ELSE IF (SS(I).GE.'0' .AND. SS(I).LE.'9') THEN XSIGN = .TRUE. ELSE XCHAR = .TRUE. END IF END IF ELSE IF (SS(I).LT.'0' .OR. SS(I).GT.'9' .OR. + ((IEPOW+ISIGN+2).LT.I)) THEN XCHAR = .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 XCHAR = .TRUE. ELSE IPOINT = I END IF ELSE IF (SS(I).LT.'0' .OR. SS(I).GT.'9') THEN XCHAR = .TRUE. ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF ENDIF I = I + 1 GO TO 40 END IF C IF (I.GT.N1) THEN IF ( .NOT. SEP) THEN LF = I - N1 IF (XCHAR) THEN ! character string LF = MIN((NIN-NOUT),LF) ! max space in array 60 CONTINUE IF (LF.GT.0) THEN WRITE (FMT(IFMT:),9000) MIN(1,LF) LF = LF - 1 IFMT = IFMT + 2 FMT(IFMT:IFMT) = ',' IFMT = IFMT + 1 NOUT = NOUT + 1 GO TO 60 ENDIF ELSE IF (IEPOW.EQ.0) THEN IEPOW = I ENDIF IF (IPOINT.EQ.0) THEN IPOINT = I ENDIF LD = MAX((IEPOW-IPOINT-1),0) WRITE (FMT(IFMT:),9020) LF,LD IFMT = IFMT + 6 FMT(IFMT:IFMT) = ',' IFMT = IFMT + 1 NOUT = NOUT + 1 ENDIF N1 = I ENDIF ENDIF 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 C 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 I = N + 1 C 20 NEL = I - 1 C RETURN END C SUBROUTINE SETEND(X) C+++ C.PURPOSE: put an end of array word in X C.COMMENTS: none C--- REAL X C REAL END DATA END /-32768./ C C *** X = END C RETURN END