← Back to branch summary

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

« back to all changes in this revision

Viewing changes to stdred/optopus/libsrc/alpha.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/alpha.for
 
1
C @(#)alpha.for 19.1 (ES0-DMD) 02/25/03 14:27:33
 
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 ALPHA(A,LENGTH,NCHAR,NREST)
 
30
C+++                                        
 
31
C.PURPOSE:  Alphanumeric handling routine
 
32
C.AUTHOR:   Rein H. Warmels
 
33
C.COMMENTS: none
 
34
C.VERSION:  87???? RHW  creation
 
35
C.VERSION:  910115 RHW  IMPLICIT NONE added
 
36
C---
 
37
      IMPLICIT     NONE
 
38
      CHARACTER*(*) A                  ! IN: input array of dimension n        
 
39
      INTEGER      LENGTH              ! IN: max length of the character string
 
40
      INTEGER      NCHAR               ! OUT: number of actual characters
 
41
      INTEGER      NREST               ! OUT: number of remaining characters
 
42
C
 
43
      CHARACTER    X
 
44
      INTEGER      I
 
45
C
 
46
C***
 
47
      NCHAR  = 0 
 
48
      DO 10 I = 1,LENGTH 
 
49
         X      = A(LENGTH-I+1:LENGTH-I+1)
 
50
         IF (X.NE.' ') THEN 
 
51
            NCHAR  = LENGTH + 1 - I 
 
52
            NREST  = LENGTH - NCHAR
 
53
            RETURN
 
54
         END IF
 
55
   10 CONTINUE 
 
56
      RETURN 
 
57
      END
 
58
 
 
59
 
 
60
 
 
61
      SUBROUTINE LENBUF(BUF,L) 
 
62
C+++
 
63
C.PURPOSE:  counts the number of effective characters in a buffer           
 
64
C.AUTHOR:   Rein H. Warmels
 
65
C.COMMENTS: none                                                            
 
66
C.VERSION:  880205 RHW Creation                                             
 
67
C.VERSION:  910115 RHW  IMPLICIT NONE added
 
68
C---
 
69
      IMPLICIT      NONE
 
70
      CHARACTER*(*) BUF                   ! IN : character string with text 
 
71
      INTEGER       L                     ! OUT: number of characters in string
 
72
C
 
73
      INTEGER       LB
 
74
C
 
75
C ***
 
76
      LB = LEN(BUF)
 
77
  100 CONTINUE
 
78
         IF (BUF(LB:LB).NE.' ' .OR. LB.EQ.0) GO TO 200
 
79
         LB = LB - 1
 
80
      GO TO 100
 
81
  200 CONTINUE
 
82
      L = LB 
 
83
      RETURN 
 
84
      END 
 
85
 
 
86
 
 
87
      INTEGER FUNCTION LENC(C)
 
88
C+++ 
 
89
C.PURPOSE:  counts the number of effective characters in a buffer
 
90
C.AUTHOR:   Rein H. warmels
 
91
C.COMMENTS: none
 
92
C.VERSION:  880205 RHW Creation
 
93
C.VERSION:  910115 RHW  IMPLICIT NONE added
 
94
C---
 
95
      IMPLICIT      NONE
 
96
      CHARACTER*(*) C                          ! IN: string containing the text
 
97
      INTEGER       I 
 
98
C
 
99
C ***
 
100
      DO 10 I = LEN(C),1,-1
 
101
         LENC = I
 
102
         IF(C(I:I).NE.' '.AND.ICHAR(C(I:I)).NE.0) GOTO 11
 
103
10    CONTINUE
 
104
 
 
105
11    CONTINUE
 
106
 
 
107
      RETURN
 
108
      END
 
109