← Back to branch summary

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

« back to all changes in this revision

Viewing changes to prim/table/libsrc/tdforlib.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:
prim/table/libsrc/tdforlib.for
 
1
C @(#)tdforlib.for      19.1 (ES0-DMD) 02/25/03 14:11:17
 
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
        INTEGER FUNCTION FORLOC(SA,SB)
 
30
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
31
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
32
C                                         all rights reserved
 
33
C
 
34
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  19:55 - 11 DEC 1987
 
35
C
 
36
C.LANGUAGE: F77+ESOext
 
37
C
 
38
C.AUTHOR: J.D.PONZ
 
39
C.IDENTIFICATION        FORLOC.FOR
 
40
C.KEYWORDS              FORTRAN FUNCTION
 
41
C.ENVIRONMENT  MIDAS
 
42
C.PURPOSE
 
43
C       Locates a character in a string.
 
44
C       Corresponds to LIB$LOCC in VAX 11 FORTRAN.
 
45
C
 
46
C------------------------------------------------------------------
 
47
        IMPLICIT  NONE
 
48
        CHARACTER*(*)   SA       ! IN : character to be found   
 
49
        CHARACTER*(*)   SB       ! IN : string to be searched
 
50
C
 
51
        INTEGER   N,KLEN,LEN
 
52
C  
 
53
C ... check string length
 
54
C
 
55
        FORLOC = 0
 
56
        KLEN   = LEN(SA)
 
57
        IF (KLEN.EQ.0) RETURN
 
58
        KLEN   = LEN(SB)
 
59
        IF (KLEN.EQ.0) RETURN
 
60
C 
 
61
C ... compare each input character with lowercase alphabet
 
62
C
 
63
        DO 100 N=1,KLEN
 
64
            IF (SA(1:1).EQ.SB(N:N)) THEN
 
65
                FORLOC = N
 
66
                RETURN
 
67
            END IF
 
68
100     CONTINUE
 
69
        RETURN
 
70
        END
 
71
        SUBROUTINE FORUPC(SA,SB)
 
72
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
73
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
74
C                                         all rights reserved
 
75
C
 
76
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  19:55 - 11 DEC 1987
 
77
C
 
78
C.LANGUAGE: F77+ESOext
 
79
C
 
80
C.AUTHOR: K.BANSE
 
81
C.IDENTIFICATION        FORUPC.FOR
 
82
C.KEYWORDS              FORTRAN FUNCTION
 
83
C.ENVIRONMENT  MIDAS
 
84
C.PURPOSE
 
85
C       Really converts characters in the input string into uppercase.
 
86
C       The routine corresponds to STR$UPCASE in VAX 11 FORTRAN
 
87
C
 
88
C------------------------------------------------------------------
 
89
        IMPLICIT  NONE
 
90
        CHARACTER*(*)   SA      ! IN  : Input string 
 
91
        CHARACTER*(*)   SB      ! OUT : Destination string
 
92
C
 
93
        INTEGER   N,KLEN,LEN,M
 
94
        CHARACTER*26    ALPHU,ALPHL
 
95
C 
 
96
        DATA   ALPHU  /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/
 
97
        DATA   ALPHL  /'abcdefghijklmnopqrstuvwxyz'/
 
98
C 
 
99
        KLEN = LEN(SA)
 
100
C 
 
101
C  compare each input character with lowercase alphabet
 
102
        DO 100 N=1,KLEN
 
103
C 
 
104
           SB(N:N) = SA(N:N)
 
105
           DO 50 M=1,26
 
106
              IF (SA(N:N).EQ.ALPHL(M:M)) SB(N:N) = ALPHU(M:M)
 
107
50         CONTINUE
 
108
C 
 
109
100     CONTINUE
 
110
C 
 
111
        RETURN
 
112
        END
 
113
 
 
114
        INTEGER FUNCTION FORSKP(SA,SB)
 
115
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
116
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
 
117
C                                         all rights reserved
 
118
C
 
119
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  19:55 - 11 DEC 1987
 
120
C
 
121
C.LANGUAGE: F77+ESOext
 
122
C
 
123
C.AUTHOR: J.D.PONZ
 
124
C.IDENTIFICATION        FORSKP.FOR
 
125
C.KEYWORDS              FORTRAN FUNCTION
 
126
C.ENVIRONMENT  MIDAS
 
127
C.PURPOSE
 
128
C       Compares a string with a given character and returns the 
 
129
C       relative position of the first nonequal character as an index.
 
130
C       The character is compared until and inequality is found or 
 
131
C       the string is exhausted. The relative position of the 
 
132
C       unequal character or zero is returned.
 
133
C       If the source string has a zero length, then zero is returned.
 
134
C       Corresponds to LIB$SKPC in VAX 11 FORTRAN.
 
135
C
 
136
C------------------------------------------------------------------
 
137
        IMPLICIT  NONE
 
138
        CHARACTER*(*)   SA       ! IN : character to be found   
 
139
        CHARACTER*(*)   SB       ! IN : string to be searched
 
140
C
 
141
        INTEGER   N,KLEN,LEN
 
142
C  
 
143
C ... check string length
 
144
C
 
145
        FORSKP = 0
 
146
        KLEN = LEN(SA)
 
147
        IF (KLEN.EQ.0) RETURN
 
148
        KLEN = LEN(SB)
 
149
        IF (KLEN.EQ.0) RETURN
 
150
C 
 
151
C ... compare each input character with lowercase alphabet
 
152
C
 
153
        DO 100 N=1,KLEN
 
154
            IF (SA(1:1).NE.SB(N:N)) THEN
 
155
                FORSKP = N
 
156
                RETURN
 
157
            END IF
 
158
100     CONTINUE
 
159
        RETURN
 
160
        END