/* @(#)f77utl.c	17.1.1.1 (ES0-DMD) 01/25/02 17:57:00 */
/*===========================================================================
  Copyright (C) 1995 European Southern Observatory (ESO)
 
  This program is free software; you can redistribute it and/or 
  modify it under the terms of the GNU General Public License as 
  published by the Free Software Foundation; either version 2 of 
  the License, or (at your option) any later version.
 
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
 
  You should have received a copy of the GNU General Public 
  License along with this program; if not, write to the Free 
  Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
  MA 02139, USA.
 
  Corresponding concerning ESO-MIDAS should be addressed as follows:
	Internet e-mail: midas@eso.org
	Postal address: European Southern Observatory
			Data Management Division 
			Karl-Schwarzschild-Strasse 2
			D 85748 Garching bei Muenchen 
			GERMANY
===========================================================================*/

/*+++++++++  Remove ESO extensions to FORTRAN 77    ++++++++++++++++++++
.COPYRIGHT   (c) 1992 European Southern Observatory
.LANGUAGE    C
.IDENT       f77utl.c
.AUTHOR      Preben J. Grosbol [ESO/IPG]
.KEYWORDS    fortran statements, program sections
.ENVIRONMENT UNIX
.VERSION     1.0  1987-Nov-12: Creation,     PJG
.VERSION     1.1  1988-Jan-15: Only warning on structure error,   PJG
.VERSION     1.2  1991-May-15: Check for CHARACTER* FUNCTION,   PJG
.VERSION     1.3  1992-Aug-07: Include return status,   PJG
------------------------------------------------------------------------*/
#include   <stdio.h>                        /* Standard I/O library     */
#include   <f77stat.h>                      /* FORTRAN statement types  */

int f77_sect(ptype,sect,perr)
int      *ptype;
int      sect;
int      *perr;
{
  int    section;

  *perr = 0;
  section = sect;
  switch (sect) {                           /* update and check section */
    case PROG_SEC : if (*ptype & PROG_STAT) break;
                    if (*ptype & (IMPL_STAT | DECL_STAT | DATA_STAT | 
                      EXEC_STAT | END_STAT)) section = IMPL_SEC;
                     else { *perr = 1; break; }
    case IMPL_SEC : if (*ptype & IMPL_STAT) break;
                    if (*ptype & (DECL_STAT | DATA_STAT | EXEC_STAT | 
                      END_STAT)) section = DECL_SEC;
                     else { *perr = 1; break; }
    case DECL_SEC : if (*ptype & DECL_STAT) break;
                    if (*ptype & (DATA_STAT | EXEC_STAT | 
                      END_STAT)) section = DATA_SEC;
                     else { *perr = 1; break; }
    case DATA_SEC : if (*ptype & DATA_STAT) break;
                    if (*ptype & (EXEC_STAT | END_STAT)) section = EXEC_SEC;
                     else { *perr = 1; break; }
    case EXEC_SEC : if (*ptype & EXEC_STAT) break;
                    if (*ptype & END_STAT) section = END_SEC;
                     else { *perr = 1; break; }
    case END_SEC  : if (*ptype & END_STAT) break;
		    if (*ptype & PROG_STAT && *ptype != PROGRAM)
                      section = PROG_SEC;
                     else { *perr = 1; break; }
  }

  return section;
}

char *find_f77(list,id,pno,ptype)        /* compare with f77 statements */
FSTAT       *list;
char          *id;
int          *pno;
int        *ptype;
{
  char     c, *pid, *pstat, *pc;

  while (pstat=list->id) {             /* loop though statement list  */
    pid = id; *pno = 0;
    while ((c = *pstat++) == *pid++ && c != '\0') (*pno)++;
    if (!c) break;
    list++;
  }

  pc = pid - 1;
  if (list->type==CHARACTER && *pc=='*') {     /* check if FUNCTION  */
    pc++;
    while ((('0' <= (c = *pc)) && c<='9') || 
	   c=='*' || c=='(' || c==')') pc++;
    pstat = "FUNCTION";
    while ((c = *pstat++) == *pc++ && c != '\0');
    *ptype = (c) ? CHARACTER : CFUNCTION;
  }
  else *ptype = (c) ? EXEC_STAT : list->type;

  return --pid;
}