1
/*===========================================================================
2
Copyright (C) 1992-2009 European Southern Observatory (ESO)
4
This program is free software; you can redistribute it and/or
5
modify it under the terms of the GNU General Public License as
6
published by the Free Software Foundation; either version 2 of
7
the License, or (at your option) any later version.
9
This program is distributed in the hope that it will be useful,
10
but WITHOUT ANY WARRANTY; without even the implied warranty of
11
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12
GNU General Public License for more details.
14
You should have received a copy of the GNU General Public
15
License along with this program; if not, write to the Free
16
Software Foundation, Inc., 675 Massachusetts Ave, Cambridge,
19
Correspondence concerning ESO-MIDAS should be addressed as follows:
20
Internet e-mail: midas@eso.org
21
Postal address: European Southern Observatory
22
Data Management Division
23
Karl-Schwarzschild-Strasse 2
24
D 85748 Garching bei Muenchen
26
===========================================================================*/
28
/*+++++++++ Remove ESO extensions to FORTRAN 77 ++++++++++++++++++++
31
.AUTHOR Preben J. Grosbol [ESO/IPG]
32
.KEYWORDS fortran statements, program sections
34
.VERSION 1.0 1987-Nov-12: Creation, PJG
35
.VERSION 1.1 1988-Jan-15: Only warning on structure error, PJG
36
.VERSION 1.2 1991-May-15: Check for CHARACTER* FUNCTION, PJG
37
.VERSION 1.3 1992-Aug-07: Include return status, PJG
40
------------------------------------------------------------------------*/
42
#include <stdio.h> /* Standard I/O library */
43
#include <f77stat.h> /* FORTRAN statement types */
45
int f77_sect(ptype,sect,perr)
54
switch (sect) { /* update and check section */
55
case PROG_SEC : if (*ptype & PROG_STAT) break;
56
if (*ptype & (IMPL_STAT | DECL_STAT | DATA_STAT |
57
EXEC_STAT | END_STAT)) section = IMPL_SEC;
58
else { *perr = 1; break; }
59
case IMPL_SEC : if (*ptype & IMPL_STAT) break;
60
if (*ptype & (DECL_STAT | DATA_STAT | EXEC_STAT |
61
END_STAT)) section = DECL_SEC;
62
else { *perr = 1; break; }
63
case DECL_SEC : if (*ptype & DECL_STAT) break;
64
if (*ptype & (DATA_STAT | EXEC_STAT |
65
END_STAT)) section = DATA_SEC;
66
else { *perr = 1; break; }
67
case DATA_SEC : if (*ptype & DATA_STAT) break;
68
if (*ptype & (EXEC_STAT | END_STAT)) section = EXEC_SEC;
69
else { *perr = 1; break; }
70
case EXEC_SEC : if (*ptype & EXEC_STAT) break;
71
if (*ptype & END_STAT) section = END_SEC;
72
else { *perr = 1; break; }
73
case END_SEC : if (*ptype & END_STAT) break;
74
if (*ptype & PROG_STAT && *ptype != PROGRAM)
76
else { *perr = 1; break; }
82
char *find_f77(list,id,pno,ptype) /* compare with f77 statements */
88
char c, *pid, *pstat, *pc;
90
while ((pstat=list->id)) { /* loop though statement list */
92
while (((c = *pstat++) == *pid++) && (c != '\0')) (*pno)++;
98
if (list->type==CHARACTER && *pc=='*') { /* check if FUNCTION */
100
while ((('0' <= (c = *pc)) && c<='9') ||
101
c=='*' || c=='(' || c==')') pc++;
103
while ((c = *pstat++) == *pc++ && c != '\0');
104
*ptype = (c) ? CHARACTER : CFUNCTION;
106
else *ptype = (c) ? EXEC_STAT : list->type;