#include "stdio.h"
#include "stdlib.h"
#include "string.h"

#define min(a,b) ((a) <= (b) ? (a) : (b))

/* Table of constant values */
typedef long int ftnlen;
typedef char *address;
typedef long int logical;
typedef long int integer;
typedef float real;

static integer c__6 = 6;
static integer c__4 = 4;
static integer c__10 = 10;
static integer memfailure = 3;

int xargc;
char **xargv;
char *F77_aloc(integer Len, char *whence);
void exit_(integer *rc);

/* ----------------------------------------------------------------------- */
/*     MSGDMP */
/* ----------------------------------------------------------------------- */
/*     Copyright (C) 2000-2022 GFD Dennou Club. All rights reserved. */
/* ----------------------------------------------------------------------- */

void s_copy(char *, char *, ftnlen, ftnlen);
void s_cat(char *, char **, integer *, integer *, ftnlen);
int s_stop(char *s, ftnlen n);

/* Subroutine */ int msgdmp_dclorig(char *clev, char *csub, char *cmsg, int 
	clev_len, int csub_len, int cmsg_len)
{
    /* Initialized data */

    static integer imsg = 0;

    /* System generated locals */
    address a__1[6], a__2[4];
    integer i__1, i__2[6], i__3[4];

    /* Builtin functions */
    /* Subroutine  int s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
	     char **, integer *, integer *, ftnlen), s_stop(char *, ftnlen);*/

    /* Local variables */
    extern integer lenc_(char *, ftnlen);
    static char cprc[32];
    static integer lprc, lmsg, nlev, lsub;
    static logical llmsg;
    static char clevx[1], cmsgx[200], csubx[32];
    static integer iunit;
    extern /* Subroutine */ int gliget_(char *, integer *, ftnlen);
    extern logical lchreq_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int gllget_(char *, logical *, ftnlen), prcnam_(
	    integer *, char *, ftnlen), osabrt_(void);
    static integer maxmsg, msglev;
    extern /* Subroutine */ int prclvl_(integer *);
    static integer lnsize;
    extern /* Subroutine */ int mszdmp_(char *, integer *, integer *, ftnlen);

    gliget_("MSGUNIT", &iunit, (ftnlen)7);
    gliget_("MAXMSG", &maxmsg, (ftnlen)6);
    gliget_("MSGLEV", &msglev, (ftnlen)6);
    gliget_("NLNSIZE", &lnsize, (ftnlen)7);
    gllget_("LLMSG", &llmsg, (ftnlen)5);
    prclvl_(&nlev);
    i__1 = min(nlev,1);
    prcnam_(&i__1, cprc, (ftnlen)32);
    s_copy(clevx, clev, (ftnlen)1, clev_len);
    s_copy(csubx, csub, (ftnlen)32, csub_len);
    lmsg = lenc_(cmsg, cmsg_len);
    lprc = lenc_(cprc, (ftnlen)32);
    lsub = lenc_(csubx, (ftnlen)32);
    if (lchreq_(clevx, "E", (ftnlen)1, (ftnlen)1)) {
	if (llmsg) {
/* Writing concatenation */
	    i__2[0] = 11, a__1[0] = "*** Error (";
	    i__2[1] = lsub, a__1[1] = csubx;
	    i__2[2] = 2, a__1[2] = "@ ";
	    i__2[3] = lprc, a__1[3] = cprc;
	    i__2[4] = 2, a__1[4] = ") ";
	    i__2[5] = lmsg, a__1[5] = cmsg;
	    s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
	} else {
/* Writing concatenation */
	    i__3[0] = 13, a__2[0] = "***** ERROR (";
	    i__3[1] = 6, a__2[1] = csubx;
	    i__3[2] = 7, a__2[2] = ") ***  ";
	    i__3[3] = lmsg, a__2[3] = cmsg;
	    s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
	}
	mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
	osabrt_();
	s_stop("", (ftnlen)0);
    }
    if (imsg < maxmsg) {
	if (lchreq_(clevx, "W", (ftnlen)1, (ftnlen)1) && msglev <= 1) {
	    ++imsg;
	    if (llmsg) {
/* Writing concatenation */
		i__2[0] = 11, a__1[0] = "- Warning (";
		i__2[1] = lsub, a__1[1] = csubx;
		i__2[2] = 2, a__1[2] = "@ ";
		i__2[3] = lprc, a__1[3] = cprc;
		i__2[4] = 2, a__1[4] = ") ";
		i__2[5] = lmsg, a__1[5] = cmsg;
		s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
	    } else {
/* Writing concatenation */
		i__3[0] = 13, a__2[0] = "*** WARNING (";
		i__3[1] = 6, a__2[1] = csubx;
		i__3[2] = 7, a__2[2] = ") ***  ";
		i__3[3] = lmsg, a__2[3] = cmsg;
		s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
	    }
	    mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
	} else if (lchreq_(clevx, "M", (ftnlen)1, (ftnlen)1) && msglev <= 0) {
	    ++imsg;
	    if (llmsg) {
/* Writing concatenation */
		i__2[0] = 11, a__1[0] = "- Message (";
		i__2[1] = lsub, a__1[1] = csubx;
		i__2[2] = 2, a__1[2] = "@ ";
		i__2[3] = lprc, a__1[3] = cprc;
		i__2[4] = 2, a__1[4] = ") ";
		i__2[5] = lmsg, a__1[5] = cmsg;
		s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
	    } else {
/* Writing concatenation */
		i__3[0] = 13, a__2[0] = "*** MESSAGE (";
		i__3[1] = 6, a__2[1] = csubx;
		i__3[2] = 7, a__2[2] = ") ***  ";
		i__3[3] = lmsg, a__2[3] = cmsg;
		s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
	    }
	    mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
	}
	if (imsg == maxmsg) {
	    s_copy(cmsgx, "+++ THE FOLLOWING MESSAGES ARE SUPPRESSED.", (
		    ftnlen)200, (ftnlen)42);
	    mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
	}
    }
    return 0;
} /* msgdmp_ */

/* ----------------------------------------------------
 * switchable MSGDMP by T. Horinouchi 2001/11/30
 *
 * function msgdmp_ in the following is to be used in place of
 * the original msgdmp_, which is renamed as msgdmp_dclorig above.
 * the new msgdmp_ calls msgdmp_func whose default value is
 * msgdmp_dclorig. Thus, the default behavior the msgdmp_ is the same
 * as before. However, msgdmp_func can be replaced by using
 * set_msgdmp_func. Also, only the behaviour on error can be modified
 * with set_mgsdmp_err.
 * ---------------------------------------------------- */

static int (*msgdmp_func)(char *clev, char *csub, char *cmsg, 
			  int clev_len, int csub_len, int cmsg_len) 
           = msgdmp_dclorig ;  /* <-- default function */

static int (*msgdmp_err_func)(char *csub, char *cmsg, 
			      int csub_len, int cmsg_len);  /* no default */

static int msgdmp_err_replaceable (char *, char *, char *, int, int, int);
	/* ^ defined below */

int set_msgdmp_func( int (*f)(char *clev, char *csub, char *cmsg, 
			      int clev_len, int csub_len, int cmsg_len) )
{
    msgdmp_func = f;
}

int set_msgdmp_err_func( int (*f)(char *csub, char *cmsg, 
				  int csub_len, int cmsg_len) )
{
    msgdmp_err_func = f;
    msgdmp_func = msgdmp_err_replaceable;
}

int msgdmp_(char *clev, char *csub, char *cmsg, ftnlen 
	clev_len, ftnlen csub_len, ftnlen cmsg_len)
{
    return( (*msgdmp_func)(clev, csub, cmsg, 
	clev_len, csub_len, cmsg_len) );
}

//何故か残しておかないとruby−dclのビルドに失敗する
//gem の 1.8.2 だけかも？
int msgdmp__(char *clev, char *csub, char *cmsg, ftnlen 
	clev_len, ftnlen csub_len, ftnlen cmsg_len)
{
    return( (*msgdmp_func)(clev, csub, cmsg, 
	clev_len, csub_len, cmsg_len) );
}

static int msgdmp_err_replaceable(char *clev, char *csub, char *cmsg, int
	clev_len, int csub_len, int cmsg_len)
     /* msgdmp_err_replaceable: by T Horinouchi 2001/11/30
	same as msgdmp_dclorig except that msgdmp_err_func (to be set 
	by set_msgdmp_err_func) is called on error */
{
    /* Initialized data */

    static integer imsg = 0;

    /* System generated locals */
    address a__1[6], a__2[4];
    integer i__1, i__2[6], i__3[4];

    /* Builtin functions */
    /* Subroutine */ /* void s_copy(char *, char *, ftnlen, ftnlen), s_cat(char *,
	     char **, integer *, integer *, ftnlen);
	     int s_stop(char *, ftnlen); */

    /* Local variables */
    extern integer lenc_(char *, ftnlen);
    static char cprc[32];
    static integer lprc, lmsg, nlev, lsub;
    static logical llmsg;
    static char clevx[1], cmsgx[200], csubx[32];
    static integer iunit;
    extern /* Subroutine */ int gliget_(char *, integer *, ftnlen);
    extern logical lchreq_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int gllget_(char *, logical *, ftnlen), prcnam_(
	    integer *, char *, ftnlen), osabrt_(void);
    static integer maxmsg, msglev;
    extern /* Subroutine */ int prclvl_(integer *);
    static integer lnsize;
    extern /* Subroutine */ int mszdmp_(char *, integer *, integer *, ftnlen);

    gliget_("MSGUNIT", &iunit, (ftnlen)7);
    gliget_("MAXMSG", &maxmsg, (ftnlen)6);
    gliget_("MSGLEV", &msglev, (ftnlen)6);
    gliget_("NLNSIZE", &lnsize, (ftnlen)7);
    gllget_("LLMSG", &llmsg, (ftnlen)5);
    prclvl_(&nlev);
    i__1 = min(nlev,1);
    prcnam_(&i__1, cprc, (ftnlen)32);
    s_copy(clevx, clev, (ftnlen)1, clev_len);
    s_copy(csubx, csub, (ftnlen)32, csub_len);
    lmsg = lenc_(cmsg, cmsg_len);
    lprc = lenc_(cprc, (ftnlen)32);
    lsub = lenc_(csubx, (ftnlen)32);
    if (lchreq_(clevx, "E", (ftnlen)1, (ftnlen)1)) {
	msgdmp_err_func(csub, cmsg, csub_len, cmsg_len);
    }
    if (imsg < maxmsg) {
	if (lchreq_(clevx, "W", (ftnlen)1, (ftnlen)1) && msglev <= 1) {
	    ++imsg;
	    if (llmsg) {
/* Writing concatenation */
		i__2[0] = 11, a__1[0] = "- Warning (";
		i__2[1] = lsub, a__1[1] = csubx;
		i__2[2] = 2, a__1[2] = "@ ";
		i__2[3] = lprc, a__1[3] = cprc;
		i__2[4] = 2, a__1[4] = ") ";
		i__2[5] = lmsg, a__1[5] = cmsg;
		s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
	    } else {
/* Writing concatenation */
		i__3[0] = 13, a__2[0] = "*** WARNING (";
		i__3[1] = 6, a__2[1] = csubx;
		i__3[2] = 7, a__2[2] = ") ***  ";
		i__3[3] = lmsg, a__2[3] = cmsg;
		s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
	    }
	    mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
	} else if (lchreq_(clevx, "M", (ftnlen)1, (ftnlen)1) && msglev <= 0) {
	    ++imsg;
	    if (llmsg) {
/* Writing concatenation */
		i__2[0] = 11, a__1[0] = "- Message (";
		i__2[1] = lsub, a__1[1] = csubx;
		i__2[2] = 2, a__1[2] = "@ ";
		i__2[3] = lprc, a__1[3] = cprc;
		i__2[4] = 2, a__1[4] = ") ";
		i__2[5] = lmsg, a__1[5] = cmsg;
		s_cat(cmsgx, a__1, i__2, &c__6, (ftnlen)200);
	    } else {
/* Writing concatenation */
		i__3[0] = 13, a__2[0] = "*** MESSAGE (";
		i__3[1] = 6, a__2[1] = csubx;
		i__3[2] = 7, a__2[2] = ") ***  ";
		i__3[3] = lmsg, a__2[3] = cmsg;
		s_cat(cmsgx, a__2, i__3, &c__4, (ftnlen)200);
	    }
	    mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
	}
	if (imsg == maxmsg) {
	    s_copy(cmsgx, "+++ THE FOLLOWING MESSAGES ARE SUPPRESSED.", (
		    ftnlen)200, (ftnlen)42);
	    mszdmp_(cmsgx, &iunit, &lnsize, (ftnlen)200);
	}
    }
    return 0;
} /* msgdmp_err_replaceable */

// tinyf2c
/* stop the excution of the program up to the statement of s
 */
int s_stop(char *s, ftnlen n)
{
	int i;

	if(n > 0)
	{
		fprintf(stderr, "STOP ");
		for(i = 0; i<n ; ++i)
			putc(*s++, stderr);
		fprintf(stderr, " statement executed\n");
	}
	exit(0);

	return 0; /* NOT REACHED */
}



void init_arg_(int argc, char **argv)
{
	xargc = argc;
	xargv = argv;
}

/* concatenate strings to a string
 */
void s_cat(char *lp, char *rpp[], ftnlen rnp[], ftnlen *np, ftnlen ll)
{
	ftnlen i, nc;
	char *rp;
	ftnlen n = *np;
	ftnlen L, m;
	char *lp0, *lp1;

	lp0 = 0;
	lp1 = lp;
	L = ll;
	i = 0;
	while(i < n) {
		rp = rpp[i];
		m = rnp[i++];
		if (rp >= lp1 || rp + m <= lp) {
			if ((L -= m) <= 0) {
				n = i;
				break;
			}
			lp1 += m;
			continue;
		}
		lp0 = lp;
		lp = lp1 = F77_aloc(L = ll, "s_cat");
		break;
	}
	lp1 = lp;
	for(i = 0 ; i < n ; ++i) {
		nc = ll;
		if(rnp[i] < nc)
			nc = rnp[i];
		ll -= nc;
		rp = rpp[i];
		while(--nc >= 0)
			*lp++ = *rp++;
	}
	while(--ll >= 0)
		*lp++ = ' ';
	if (lp0) {
		memcpy(lp0, lp1, L);
		free(lp1);
	}
}

/* assign strings:  a = b 
 */
void s_copy(register char *a, register char *b, ftnlen la, ftnlen lb)
{
	register char *aend, *bend;

	aend = a + la;

	if(la <= lb){
		if (a <= b || a >= b + la)
			while(a < aend)
				*a++ = *b++;
		else
			for(b += la; a < aend; )
				*--aend = *--b;
	}else {
		bend = b + lb;
		if (a <= b || a >= bend){
			while(b < bend)
				*a++ = *b++;
		}
		else {
			a += lb;
			while(b < bend)
				*--a = *--bend;
			a += lb;
		}
		while(a < aend)
			*a++ = ' ';
	}
}


/* allocat memory of legth of Len
*/
char *F77_aloc(integer Len, char *whence)
{
	char *rv;
	unsigned int uLen = (unsigned int) Len;	/* for K&R C */

	if (!(rv = (char*)malloc(uLen))) {
		fprintf(stderr, "malloc(%u) failure in %s\n",
			uLen, whence);
		exit_(&memfailure);
	}
	return rv;
}


void exit_(integer *rc)
{
	exit(*rc);
}

