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                                                                       
