/* @(#)putline.c	17.1.1.1 (ESO-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) 1988 European Southern Observatory
.LANGUAGE    C
.IDENT       putline.c
.AUTHOR      Preben J. Grosbol [ESO/IPG]
.KEYWORDS    ESO fortran, output line
.ENVIRONMENT UNIX
.COMMENT
.VERSION     1.0   10-Nov-1987: Creation,     PJG

 010706		last modif

------------------------------------------------------------------------*/

#include   <stdio.h>                        /* standard I/O functions   */
#include   <ctype.h>                        /* character types          */
#include   <f77ext.h>                       /* definition of constants  */
#include   <f77stat.h>                      /* F77 statements           */

extern    int                   bit64;      /* flag for 64bit CPU (=1)  */
extern    int                  x_flag;      /* extension option flag    */
extern    int                  no_lid;      /* no. of line identifiers  */
extern    int                     sno;      /* current no. of labels    */
extern    int                statno[];      /* statement label no.      */
extern    char                 stmt[];      /* present statement        */
extern    char   lbuf[MXLBUF][MXLINE];      /* buffer for input lines   */
extern    LID                   lid[];      /* list of line identifiers */
extern    int                do_level;      /* DO stack pointer         */
extern    int                do_label;      /* DO label                 */

static    int            dostk[MXLDO];      /* DO label stack           */

static char i8pntrs[256];
static int  i8indx = 0, i8flag = 1;
static int  cdifU = 'A' - 'a';


put_line(ofp,action,stype,labno)            /* correct and output line  */
FILE         *ofp;
int          action;
int          stype;
int          labno;
{
  int          c,n,i,newlab;
  char         *pc,*pnid;
  ID           *pid;

  if (stype == INCLUDE && x_flag & INC_FLAG) return;
  if (stype == IMPLICITNONE && x_flag & IMP_FLAG) return;

  if (x_flag & LN_FLAG)                     /* substitute long names    */
    for (n=0; n<no_lid; n++) {              /* go through all ident.    */
      pid = lid[n].id;
      i = lid[n].size;
      pnid = pid->sname;
      if (i && *pnid) {                     /* modify only long ident.  */
	pc = lid[n].sid;
	while (*pc = *pnid++) { pc++; i--; }
	while (i--) *pc++ = ' ';
      }
    }

  if ((x_flag & DO_FLAG) && action == DO_ACTION) { /* remove DO - ENDDO */
    if (stype == DO) {
      newlab = do_label++;
      dostk[do_level++] = newlab;
      if (MXLDO<do_level) fprintf(stderr,"Error: Stack error in DO-ENDDO");
      statno[sno++] = -newlab;
      if (labno) fprintf(ofp,"%5d DO%5d,",labno,newlab);
	else fprintf(ofp,"      DO%5d,",newlab);
      for (n=0; !lid[n].size && n<no_lid; n++);
      pc = lid[n].sid;
      n = 8;
      while (c = *pc++) {                       /* write out one statement  */
        if (n++<66) putc(c,ofp);
          else { n = 1; fprintf(ofp,"\n     +%c",c); }
      }
      putc('\n',ofp);
    }
    else if (stype == ENDDO) {
      if (do_level<0) fprintf(stderr,"Error: Stack error in DO-ENDDO");
      if (labno) fprintf(ofp,"%5d CONTINUE\n",labno);
      fprintf(ofp,"%5d CONTINUE\n",dostk[--do_level]);
    }
    return;
  }

  if (labno)                                /* write label if any       */
    fprintf(ofp,"%5d ",labno);
   else fprintf(ofp,"      ");


  /*  change  INTEGER*8   to   INTEGER  if not 64 bit machine  */
  /*  KB  990420  */

  if (strncmp(stmt,"INTEGER",7) == 0)
     {
     if ((stmt[7] == '*') && (stmt[8] == '8'))
        {
        if (bit64 == 0)
           {
           stmt[7] = ' ';
           stmt[8] = ' ';
           }
        n = filli8(stmt+9);
        if (n < 0) i8flag = 0;		/* disable checks */
        }
     }

  /* look for MADRID(...) */

  else if (i8flag == 1)
     {
     char  klaus[24], ulli[304], *ipntr, *jpntr;
     int   j, uindx;

     uindx = 0;
     ipntr = stmt;
     while ((n = CGN_INDEXS(ipntr,"MADRID")) > -1)
        {
        if (strncmp(ipntr,"COMMON",6) == 0) break;
        (void) CGN_UPCOPY(klaus,ipntr+n+7,20);
        i = CGN_INDEXC(klaus,')');
        if (i < 1)
           {
           (void) printf("weird line: %s\n",stmt);
           break;
           }
        j = i;				/* handle MADRID(PNTR(K)) */
        i = CGN_INDEXC(klaus,'(');
        if ((i < 1) || (i > j)) i = j;

        j = i;				/* handle MADRID(PNTR+1024) */
        i = CGN_INDEXC(klaus,'+');
        if ((i < 1) || (i > j)) i = j;
            
        klaus[i] = '\0';

        ipntr += (i + 1);
        (void) strcpy(ulli+uindx,klaus);
        uindx += (i + 1);
        }
        
     if (uindx > 0) 
        {
        j = 0;
        jpntr = ulli;
        while (j < uindx)
           {
           i = 0;
           ipntr = i8pntrs;
           while (i < i8indx)
              {
              if (strcmp(jpntr,ipntr) == 0) goto ok_1;

              i += (int) strlen(ipntr) + 1;
              ipntr = i8pntrs + i;
              }
           (void) printf("Warning: MADRID with missing pointer (%s)\n",jpntr); 
           (void) printf(">  %s\n",stmt);
           goto ok;

          ok_1:
           j += (int) strlen(jpntr) + 1;
           jpntr = ulli + j;
           }
        }
     }

 ok:
  n = 0; pc = stmt;
  while (c = *pc++) {                       /* write out one statement  */
    if (n++<66) putc(c,ofp);
      else { n = 1; fprintf(ofp,"\n     +%c",c); }
  }
  putc('\n',ofp);

  return;
}

/*

*/

int filli8(line)
char *line;

{
int  count, n, k, mm;

char  mybuf[80], *pntr;


(void) strcpy(mybuf,line);		/* copy line - it's safer... */
pntr = mybuf;
count = 0;


again:
n = CGN_INDEXC(pntr,',');
if (n > 0) *(pntr+n) = '\0';


k = CGN_INDEXC(pntr,'(');		/* handle PNTR(N) */
if (k > 1) pntr[k] = '\0';

(void) CGN_UPCOPY(&i8pntrs[i8indx],pntr,20);

mm = (int) strlen(pntr) + 1;
i8indx += mm;
if (i8indx > 248)
   {
   (void) printf("Warning: I*8 pointers buffer overflow...\n");
   return (-1);
   }

count ++;

if (n > 0) 
   {
   pntr += (n + 1);
   goto again;
   }


/*
n = 0;
while (n < i8indx)
   {
   printf("%s\n",&i8pntrs[n]);
   n += (int) strlen(&i8pntrs[n]) + 1;
   }
*/

return count;
}

/*

*/

int CGN_UPCOPY(strb,stra,lim)
/*++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
 this function copies + converts all lowercase to uppercase for a given
 number of chars. of input string
.RETURN
 nothing
--------------------------------------------------*/

char *stra;     /* IN: input string */
char *strb;     /* IN: output string in uppercase  */
int   lim;      /* IN: no. of chars. to do */

{
register int  count;

register char   rp;



for (count=0; count<lim; count++)
   {
   rp = *stra++;
   if (rp == '\0')
      {
      *strb = rp;
      return count;
      }

   if ((rp >= 'a') && (rp <= 'z')) rp += cdifU;

   *strb++ = rp;
   }

return lim;
}


int CGN_INDEXC(s,t)
/*++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
 returns position of single character in input string
.RETURN
 returns position of single character in input string, -1 if not there
--------------------------------------------------*/

char *s;    /* input string  */
char t;     /* test character */

{
register int i;

char   *cp;


cp = s;
for (i=0; *cp != '\0'; i++)
   {
   if (t == *cp++) return (i);
   }

return (-1);                    /* character not found */
}

int CGN_INDEXS(s,t)

/*++++++++++++++++++++++++++++++++++++++++++++++++++
.PURPOSE
 find position of substring in input string.

.RETURN
 returns index of substring in input string (= 0,1,2,...),
         -1 if not there
--------------------------------------------------*/

char *s;    /* input string  */
char *t;    /* substring */

{
register int nr;

register char  *cp, *cq, *qq, *t2;


cp = s;
t2 = t + 1;

for (nr=0; *cp != '\0'; nr++)
   {
   if (*cp++ == *t)                     /* first char. has to match */
      {
      qq = cp;                          /* points to 2. char in input string */
      for (cq=t2; *cq != '\0'; )
         {
         if (*cq++ != *qq++) goto no_match;
         }
      return (nr);
      }
no_match:
   ;
   }

return (-1);                    /* substring not found */
}