← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to stdred/optopus/libsrc/usrinp.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
stdred/optopus/libsrc/usrinp.for
 
1
C @(#)usrinp.for        13.1.1.1 (ES0-DMD) 06/02/98 18:30:08
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
      SUBROUTINE USRINP(A,N,TYPE,CHARST) 
 
30
 
 
31
C.PURPOSE:  Decode a character string into integer or real array
 
32
C.AUTHOR:   J.P. Terlouw, Kapteynlab, Groningen
 
33
C.COMMENTS: none
 
34
C.VERSION:  ?????? RHW implementation
 
35
C.VERSION:  910115 RHW IMPLICIT NONE added
 
36
C---  
 
37
      IMPLICIT     NONE
 
38
C 
 
39
      INTEGER      NR8
 
40
      PARAMETER    (NR8=512)                                           
 
41
      INTEGER      MAXLP
 
42
      PARAMETER    (MAXLP=10)
 
43
C
 
44
      INTEGER      IREAL, ILOOP
 
45
      INTEGER      N, I, II
 
46
      INTEGER      IPOS, ITYPE
 
47
      INTEGER      IA, IIN 
 
48
      INTEGER      NREAL
 
49
      INTEGER      NI, NLOOP
 
50
      INTEGER      NCH, NREST
 
51
      INTEGER      NWORD, INSERT
 
52
      INTEGER      DOLOOP(2,MAXLP)
 
53
      INTEGER      NEL
 
54
C 
 
55
      REAL         A(NR8)       
 
56
      REAL         AA
 
57
      REAL         B8(NR8)
 
58
      REAL         INCR
 
59
      REAL         LOW                                      
 
60
      REAL         RA                                                    
 
61
      REAL         UPP
 
62
C 
 
63
      LOGICAL      LOOP,SEP,ERR                                                 
 
64
C 
 
65
      CHARACTER    TYPE
 
66
      CHARACTER    CHARST(72)
 
67
      CHARACTER    B1(72)                                            
 
68
      CHARACTER    ATYPE(2),LPSYM                                          
 
69
C 
 
70
      EXTERNAL     NEL  
 
71
C                                                                               
 
72
      EQUIVALENCE  (RA,IA,AA)                                                   
 
73
C
 
74
      DATA         ATYPE     /'R','I'/ 
 
75
C 
 
76
C ***
 
77
      ERR    = .FALSE.               ! error in do-loop                         
 
78
      LPSYM  = ':'                   ! loop symbol                              
 
79
      NI     = 0                     ! initial number of used words for array   
 
80
      IPOS   = 0                     ! starting for array pointer               
 
81
      ITYPE  = 1                     ! default type is real                     
 
82
                                                                                
 
83
      DO 10 I = 1,72                                                            
 
84
         B1(I)  = ' '                                                           
 
85
   10 CONTINUE                                                                  
 
86
      CALL ALPHA(CHARST,72,NCH,NREST)                                           
 
87
                                                                                
 
88
      DO 20 II = 1,NCH                                                          
 
89
         B1(II) = CHARST(II)                                                    
 
90
   20 CONTINUE                                                                  
 
91
                                                                                
 
92
      DO 30 I = 1,2                                                             
 
93
         IF (TYPE.EQ.ATYPE(I)) THEN                                 ! what type?
 
94
            ITYPE  = I                                                          
 
95
         END IF                                                                 
 
96
   30 CONTINUE                                                                  
 
97
C                                                                               
 
98
C *** GET INPUT PARAMETERS IF PRESENT                                           
 
99
C                                                                               
 
100
      IF (NCH.NE.0) THEN                                                        
 
101
         ERR    = .FALSE.                                     ! reset error flag
 
102
         NLOOP  = 0                                                             
 
103
         IF ((ITYPE.EQ.1) .OR. (ITYPE.EQ.3)) THEN                  ! decode loop
 
104
            DO 40 I = 1,MAXLP                                                   
 
105
               DOLOOP(1,I) = 0                                                  
 
106
               DOLOOP(2,I) = 0                                                  
 
107
   40       CONTINUE                                                            
 
108
            NLOOP  = 1                                                          
 
109
            NWORD  = 1                              ! startword of do-loop in b1
 
110
            INSERT = 0                                                          
 
111
            LOOP   = .FALSE.                                                    
 
112
            SEP    = .TRUE.                                                     
 
113
            DO 50 I = 1,NCH                                                     
 
114
               IF (B1(I).EQ.LPSYM) THEN                                         
 
115
                  IF (B1(I-1).EQ.' ' .OR. B1(I+1).EQ.' ') THEN      ! bad syntax
 
116
                     ERR    = .TRUE.                                            
 
117
                     GO TO 60                                                   
 
118
                  END IF                                                        
 
119
                  IF (DOLOOP(2,NLOOP).EQ.1) THEN                                
 
120
                     DOLOOP(2,NLOOP) = 2               ! increment value present
 
121
                     INSERT = INSERT + 1                                        
 
122
                                                                                
 
123
                  ELSE IF (DOLOOP(2,NLOOP).EQ.2) THEN                           
 
124
                     ERR    = .TRUE.             ! error in do-loop input string
 
125
                     NCH    = 0                                                 
 
126
                     GO TO 60                                     ! back to inpu
 
127
                  ELSE                                     ! upper value present
 
128
                     DOLOOP(1,NLOOP) = NWORD + INSERT                           
 
129
                     DOLOOP(2,NLOOP) = 1                                        
 
130
                     INSERT = INSERT + 1                                        
 
131
                  END IF                                                        
 
132
                  LOOP   = .TRUE.                                               
 
133
                  B1(I)  = ','                                                  
 
134
               ELSE                                                             
 
135
                  IF (B1(I).EQ.' ' .OR. B1(I).EQ.',') THEN        ! sep. symbols
 
136
                     IF ( .NOT. SEP) THEN                                       
 
137
                        NWORD  = NWORD + 1                                      
 
138
                        SEP    = .TRUE.                                         
 
139
                     END IF                                                     
 
140
C                                                                               
 
141
                     IF (LOOP) THEN                                             
 
142
                        NLOOP  = NLOOP + 1                                      
 
143
                        LOOP   = .FALSE.                                        
 
144
                     END IF                                                     
 
145
                  ELSE                                                          
 
146
                     SEP    = .FALSE.                                           
 
147
                  END IF                                                        
 
148
               END IF                                                           
 
149
   50       CONTINUE                                                            
 
150
C                                                                               
 
151
   60       CONTINUE                                                            
 
152
            IF ((.NOT.LOOP) .AND. (.NOT.ERR)) THEN                              
 
153
               NLOOP  = NLOOP - 1                                               
 
154
            END IF                                                              
 
155
         END IF                                                                 
 
156
      END IF                                                                    
 
157
C                                                                               
 
158
      IF ((NCH.GT.0) .AND. (.NOT.ERR)) THEN    ! decode input into real or char.
 
159
         CALL DECUSR(B1,NCH,B8,NR8)           ! decodes input array into b8(nr8)
 
160
         NI     = NEL(B8,NR8)         ! actual number of words (=array elements)
 
161
      END IF                                                                    
 
162
C                                                                               
 
163
C  *** CONSTRUCT THE OUTPUT ARRAY ************************************          
 
164
C                                                                               
 
165
      IPOS   = 0   ! position in a                                              
 
166
      ILOOP  = 1   ! next loop (if present)                                     
 
167
      IIN    = 0   ! position in b8                                             
 
168
      IF (NI.GT.0) THEN                                                         
 
169
   70    CONTINUE                                                               
 
170
         IIN    = IIN + 1                                                       
 
171
         RA     = B8(IIN)                                                       
 
172
         IF (ITYPE.EQ.3) THEN                          ! real+integer conversion
 
173
            IA     = NINT(RA)                                                   
 
174
         END IF                                                                 
 
175
         IF (IPOS+1.LE.N) THEN                ! conversion if ipos+1<# array el.
 
176
            A(IPOS+1) = RA                                                      
 
177
         END IF                                                                 
 
178
         IPOS   = IPOS + 1                            ! increase position by one
 
179
         IF (IIN.EQ.DOLOOP(1,ILOOP)) THEN                                       
 
180
            LOW    = B8(IIN)                                                    
 
181
            IIN    = IIN + 1                                                    
 
182
            UPP    = B8(IIN)                                                    
 
183
            IF (DOLOOP(2,ILOOP).EQ.1) THEN              ! no increment was given
 
184
               INCR   = 1.                                                      
 
185
            ELSE                                                                
 
186
               IIN    = IIN + 1                                                 
 
187
               INCR   = B8(IIN)                                                 
 
188
            END IF                                                              
 
189
            AA     = ((UPP-LOW)/INCR)              ! # of reals to be added in A
 
190
            NREAL  = ANINT(AA)                                                  
 
191
            IF (NREAL.GT.0) THEN                                                
 
192
               DO 80 IREAL = 1,NREAL                                            
 
193
                  LOW    = LOW + INCR                                           
 
194
                  RA     = LOW                                                  
 
195
                  IF (ITYPE.EQ.3) THEN                ! real+integer conversion 
 
196
                     IA     = NINT(RA)                                          
 
197
                  END IF                                                        
 
198
                  IF (IPOS+1.LE.N) THEN       ! conversion if ipos+1<# array el.
 
199
                     A(IPOS+1) = RA                                             
 
200
                  END IF                                                        
 
201
                  IPOS   = IPOS + 1                   ! increase position by one
 
202
   80         CONTINUE                                                          
 
203
            END IF                                                              
 
204
            ILOOP  = ILOOP + 1                                                  
 
205
         END IF                                                                 
 
206
         IF (IIN.LT.NI) GO TO 70                                                
 
207
      END IF                                                                    
 
208
C                                                                               
 
209
      IF (IPOS.LT.N) THEN                                                       
 
210
         CALL SETEND(A(IPOS+1))                                                 
 
211
      END IF                                                                    
 
212
                                                                                
 
213
      RETURN                                                                    
 
214
      END                                                                       
 
215
C 
 
216
      SUBROUTINE DECUSR(SS,L,ARRAY,NIN)                                         
 
217
C+++                                                                            
 
218
C.PURPOSE:  Subroutine to decode input string into a real array
 
219
C.AUTHOR:   J.P. Terlouw, Kapteynlab Groningen
 
220
C.COMMENTS: none
 
221
C.VERSION:  87???? RHW adjustments for and implementation in MIDAS
 
222
C.VERSION:  910115 RHW IMPLICIT NONE added
 
223
C---                                                                            
 
224
      IMPLICIT   NONE
 
225
      INTEGER    L                            ! IN: length of character string
 
226
      CHARACTER  SS(L)                        ! IN: character string
 
227
      REAL       ARRAY(*)                    ! OUT: real array  
 
228
      INTEGER    NIN                          ! OUT: length of the array
 
229
C
 
230
      INTEGER    IPOINT, IEPOW, ISIGN
 
231
      INTEGER    I, II, IARR, IFMT
 
232
      INTEGER    J
 
233
      INTEGER    NOUT, N1 
 
234
      INTEGER    LF, LD
 
235
      REAL       ENDLN
 
236
C
 
237
      CHARACTER  FMT*150,SSS*150                                                
 
238
      LOGICAL    RREAL,EPOW,XSIGN,XCHAR,SEP    
 
239
C 
 
240
 9000 FORMAT ('A',I1)                                                           
 
241
 9010 FORMAT (I2.2,'X')                                                         
 
242
 9020 FORMAT ('F',I2.2,'.',I2.2)                                                
 
243
C                                                                               
 
244
C *** start                                                                     
 
245
      RREAL   = .FALSE.
 
246
      EPOW   = .FALSE. 
 
247
      XSIGN   = .FALSE. 
 
248
      XCHAR   = .FALSE. 
 
249
      SEP    = .TRUE. 
 
250
      IPOINT = 0     
 
251
      IEPOW  = 0    
 
252
      ISIGN  = 0   
 
253
C                                                                               
 
254
      DO 10 II = 1,L                          !  put ss(1 --> l) into sss(1:l)  
 
255
         SSS(II:II) = SS(II)                                                    
 
256
   10 CONTINUE                                                                  
 
257
      DO 20 II = L+1,150                                                      
 
258
         SSS(II:II) = ' '                                                       
 
259
   20 CONTINUE                                                                  
 
260
C                                                                               
 
261
      I      = 1                                 !   index used for ss(1 ---> l)
 
262
      NOUT   = 0                                !  # of elements filled in array
 
263
      FMT(1:1) = '('                                                            
 
264
      IFMT   = 2                                                                
 
265
      N1     = 1                                !   first position of next field
 
266
      CALL SETEND(ENDLN)                                                        
 
267
      DO 30 IARR = 1,NIN       
 
268
         ARRAY(IARR) = ENDLN  
 
269
   30 CONTINUE               
 
270
C                                                                               
 
271
   40 CONTINUE              
 
272
      IF (I.LE.L .AND. NOUT.LT.NIN) THEN  
 
273
         IF ((SS(I).EQ.' ') .OR. (SS(I).EQ.',')
 
274
     +      .OR. (SS(I).EQ.':')) THEN         
 
275
            IF ( .NOT. SEP) THEN             
 
276
               LF     = I - N1                              !   character string
 
277
               IF (XCHAR) THEN               
 
278
                  LF = MIN(((NIN-NOUT)*1),LF)         !   max space in array
 
279
   50             CONTINUE 
 
280
                  IF (LF.GT.0) THEN  
 
281
                     WRITE (FMT(IFMT:),9000) MIN(1,LF)
 
282
                     LF     = LF - 1    
 
283
                     IFMT   = IFMT + 2 
 
284
                     FMT(IFMT:IFMT) = ','   
 
285
                     IFMT   = IFMT + 1     
 
286
                     NOUT   = NOUT + 1    
 
287
                     GO TO 50            
 
288
                  END IF                
 
289
               ELSE                    
 
290
                  IF (IEPOW.EQ.0) THEN 
 
291
                     IEPOW  = I       
 
292
                  END IF             
 
293
                  IF (IPOINT.EQ.0) THEN     
 
294
                     IPOINT = I            
 
295
                  END IF                  
 
296
                  LD     = MAX((IEPOW-IPOINT-1),0)  
 
297
                  WRITE (FMT(IFMT:IFMT+5),9020) LF,LD      
 
298
                  IFMT   = IFMT + 6                       
 
299
                  FMT(IFMT:IFMT) = ','                   
 
300
                  IFMT   = IFMT + 1                     
 
301
                  NOUT   = NOUT + 1                    
 
302
               END IF                                 
 
303
               N1     = I                            
 
304
C                                                                               
 
305
               RREAL   = .FALSE.                    
 
306
               EPOW   = .FALSE.                    
 
307
               XSIGN   = .FALSE.                   
 
308
               XCHAR   = .FALSE.                  
 
309
               SEP    = .TRUE.                  
 
310
               IPOINT = 0                      
 
311
               IEPOW  = 0                     
 
312
               ISIGN  = 0                    
 
313
            END IF                          
 
314
         ELSE                              
 
315
            IF (SEP) THEN                 
 
316
               LF     = I - N1           
 
317
               IF (LF.GT.0) THEN        
 
318
                  WRITE (FMT(IFMT:IFMT+2),9010) LF 
 
319
                  IFMT   = IFMT + 3               
 
320
                  FMT(IFMT:IFMT) = ','           
 
321
                  IFMT   = IFMT + 1             
 
322
               END IF                          
 
323
               N1     = I                     
 
324
C                                                                               
 
325
C *** input element is real                                                     
 
326
               IF (SS(I).GE.'0' .AND. SS(I).LE.'9' .OR. SS(I).EQ.  
 
327
     +            '+' .OR. SS(I).EQ.'-') THEN                     
 
328
                  RREAL   = .TRUE.                               
 
329
               ELSE                                             
 
330
                  IF (SS(I).EQ.'.') THEN                       !   decimal point
 
331
                     RREAL   = .TRUE.                          
 
332
                     IPOINT = I                               
 
333
                  ELSE                                       
 
334
                     XCHAR   = .TRUE.               !  input element is character
 
335
                  END IF                                    
 
336
               END IF                                      
 
337
               SEP    = .FALSE.                           
 
338
            ELSE                                         
 
339
               IF ( .NOT. XCHAR) THEN                    
 
340
                  IF (EPOW) THEN                       
 
341
                     IF ( .NOT. XSIGN) THEN            
 
342
                        IF (SS(I).EQ.'+' .OR. SS(I).EQ.'-') THEN  
 
343
                           ISIGN  = 1                            
 
344
                           XSIGN   = .TRUE.                      
 
345
                        ELSE                                   
 
346
                           IF (SS(I).GE.'0' .AND. SS(I).LE.'9') THEN   
 
347
                              XSIGN   = .TRUE.                         
 
348
                           ELSE                                      
 
349
                              XCHAR   = .TRUE.                       
 
350
                           END IF                                  
 
351
                        END IF                                    
 
352
                     ELSE  
 
353
                        IF (SS(I).LT.'0' .OR. SS(I).GT.'9' .OR.  
 
354
     +                     ((IEPOW+ISIGN+2).LT.I)) THEN         
 
355
                           XCHAR   = .TRUE.                     
 
356
                        END IF                                
 
357
                     END IF                                  
 
358
                  ELSE                                      
 
359
                     IF (SS(I).EQ.'E') THEN                
 
360
                        EPOW   = .TRUE.                   
 
361
                        IEPOW  = I                       
 
362
                     ELSE                               
 
363
                        IF (SS(I).EQ.'.') THEN         
 
364
                           IF (IPOINT.GT.0) THEN      
 
365
                              XCHAR   = .TRUE.        
 
366
                           ELSE                     
 
367
                              IPOINT = I           
 
368
                           END IF                 
 
369
                        ELSE                     
 
370
                           IF (SS(I).LT.'0' .OR. SS(I).GT.'9') THEN  
 
371
                              XCHAR   = .TRUE.                       
 
372
                           ENDIF                                   
 
373
                        ENDIF                                     
 
374
                     ENDIF                                       
 
375
                  ENDIF                                         
 
376
               ENDIF                                           
 
377
            ENDIF                                             
 
378
         ENDIF                                               
 
379
         I = I + 1                                          
 
380
         GO TO 40                                         
 
381
      END IF                                             
 
382
C                                                       
 
383
      IF (I.GT.N1) THEN                                
 
384
         IF ( .NOT. SEP) THEN                         
 
385
            LF     = I - N1                          
 
386
            IF (XCHAR) THEN                             !   character string
 
387
               LF     = MIN((NIN-NOUT),LF)            !   max space in array
 
388
60             CONTINUE                             
 
389
               IF (LF.GT.0) THEN                   
 
390
                  WRITE (FMT(IFMT:),9000) MIN(1,LF)
 
391
                  LF = LF - 1                         
 
392
                  IFMT   = IFMT + 2                      
 
393
                  FMT(IFMT:IFMT) = ','                  
 
394
                  IFMT   = IFMT + 1                    
 
395
                  NOUT   = NOUT + 1                   
 
396
                  GO TO 60                           
 
397
               ENDIF                                
 
398
            ELSE                                   
 
399
               IF (IEPOW.EQ.0) THEN               
 
400
                  IEPOW  = I                     
 
401
               ENDIF                            
 
402
               IF (IPOINT.EQ.0) THEN           
 
403
                  IPOINT = I                  
 
404
               ENDIF                         
 
405
               LD     = MAX((IEPOW-IPOINT-1),0) 
 
406
               WRITE (FMT(IFMT:),9020) LF,LD   
 
407
               IFMT   = IFMT + 6                    
 
408
               FMT(IFMT:IFMT) = ','                
 
409
               IFMT   = IFMT + 1                  
 
410
               NOUT   = NOUT + 1                 
 
411
            ENDIF                               
 
412
            N1 = I                             
 
413
         ENDIF                                
 
414
      ENDIF                                  
 
415
C                                                                               
 
416
      FMT(IFMT-1:IFMT-1) = ')'              
 
417
      IF (NOUT.GT.0) THEN                  
 
418
          READ (SSS(1:L),FMT=FMT(1:IFMT-1)) (ARRAY(J),J=1,NOUT)   
 
419
      END IF                                                     
 
420
C                                                                               
 
421
      RETURN                                                    
 
422
      END                                                      
 
423
C 
 
424
      INTEGER FUNCTION NEL(A,N)
 
425
C+++
 
426
C.PURPOSE:  Count the number of words in the input array of dimension
 
427
C           N by testing the array on -0 value
 
428
C.AUTHOR:   Rein H. Warmels
 
429
C.COMMENTS: none
 
430
C.VERSION:  890117 RHW Documented
 
431
C.VERSION:  910115 RHW IMPLICIT NONE added
 
432
C---
 
433
      IMPLICIT NONE
 
434
      INTEGER  N
 
435
      REAL     A(N)
 
436
C
 
437
      INTEGER  I 
 
438
      REAL     END
 
439
C
 
440
      DATA     END   /-32768./
 
441
C
 
442
C ***
 
443
      DO 10 I = 1,N
 
444
         IF (A(I).EQ.END) THEN
 
445
            GO TO 20
 
446
        END IF
 
447
   10 CONTINUE
 
448
      I = N + 1
 
449
C 
 
450
20    NEL = I - 1
 
451
C 
 
452
      RETURN
 
453
      END
 
454
C 
 
455
      SUBROUTINE SETEND(X)                                                      
 
456
C+++                                                                            
 
457
C.PURPOSE:  put an end of array word in X    
 
458
C.COMMENTS: none
 
459
C---                                                                            
 
460
      REAL   X
 
461
C
 
462
      REAL   END        
 
463
      DATA   END   /-32768./
 
464
C
 
465
C ***
 
466
      X = END                                                              
 
467
C 
 
468
      RETURN                                                                    
 
469
      END