/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:30:52 */
/*FOR_C Options SET: ftn=u io=c no=p op=aimnv s=dbov str=l x=f - prototypes */
#include <math.h>
#include "fcrt.h"
#include "dmess.h"
#include <string.h>
#include <float.h>
#include <stdio.h>
#include <stdlib.h>
		/* PARAMETER translations */
#define	LENBUF	250
#define	MEVBAS	10
#define	MEVLAS	33
		/* end of PARAMETER translations */
 
	/* COMMON translations */
struct t_messcc {
	long int kciwid, kccwid, kcrwid, lbeg, lend, lfprec, lgprec;
	}	messcc;
struct t_cmessi {
	long int sunit, lhead, kdfdef, linmsg, linerr, munit, eunit, kscrn,
	 kdiag, maxerr, lstop, lprint, kdf, ntext, nidat, nfdat, nmdat,
	 mdat[5], tabspa, errcnt, ichar0, imag, inc, irc, itext, iwf,
	 iwg, kdi, kdj, kline, kshift, kspec, kt, lasti, lbuf, lenlin,
	 lenout, lentry, lentxt, locbeg, lstrt, ltext, maxwid[2], mpt,
	 nrow, ncol, ndim, ounit;
	LOGICAL32 gotfmt, xarg, xargok;
	}	cmessi;
struct t_cmessc {
	char buf[251], dols[73], fmtf[21], fmtg[16], fmti[8], fmtj[8],
	 fmtt[16], fmtim[2][8];
	}	cmessc;
	/* end of COMMON translations */
void /*FUNCTION*/ dmess(
long mact[],
char *text, int text_s,
long idat[],
double fdat[])
{
#define TEXT(I_,J_)	(text+(I_)*(text_s)+(J_))
	long int _d_l, _d_m, _do0, _do1, _l0, icol, id, j, kbig, kexe,
	 ksma, neg;
	double fbig, fout, fsma;
	static long ldfdef = 0;
		/* OFFSET Vectors w/subscript range: 1 to dimension */
	double *const Fdat = &fdat[0] - 1;
	long *const Idat = &idat[0] - 1;
	long *const Mact = &mact[0] - 1;
		/* end of OFFSET VECTORS */
 
	/* Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
	 * ALL RIGHTS RESERVED.
	 * Based on Government Sponsored Research NAS7-03001.
	 *>> 2009-09-27 DMESS Krogh  Same as below, in another place.
	 *>> 2009-07-23 DMESS Krogh  Changed ,1x to :1x in write to FMTF.
	 *>> 2008-06-13 DMESS Krogh  Changed -0's to 0.
	 *>> 2007-09-08 DMESS Krogh  Fixed definitions of MEVLAS.
	 *>> 2006-10-08 DMESS Krogh  Another try, see 2005-05-26
	 *>> 2006-10-08 DMESS Krogh  Fixed minor problem in matrix/vector output.
	 *>> 2006-10-01 DMESS Krogh  Print NaN's and infity (at least for g77).
	 *>> 2006-07-01 DMESS Krogh  messxc => dmessxc (and not static) (for C)
	 *>> 2006-04-07 DMESS Krogh  Major rewrite of code for F.Pt. format.
	 *>> 2006-04-04 DMESS Krogh  Fixes in C code for vectors & matrices.
	 *>> 2006-04-02 DMESS Krogh  Added code for output of sparse vector.
	 *>> 2005-07-10 DMESS Krogh  Small adjustment for last correction.
	 *>> 2005-05-26 DMESS Krogh  Fixed "*****" output in boundary case.
	 *>> 2002-05-16 DMESS Krogh  Added way for user to get error count.
	 *>> 2002-03-27 DMESS Krogh  Fixed crash when number is -INF.
	 *>> 2001-06-08 DMESS Krogh  Eliminated Hollerith in formats.
	 *>> 2001-05-25 DMESS Krogh  Added a couple of commas in formats.
	 *>> 1997-06-17 DMESS Krogh  In C code made messxc, static.
	 *>> 1996-07-12 DMESS Krogh  Changes to use .C. and C%%.
	 *>> 1996-03-30 DMESS Krogh  Added external statement.
	 *>> 1994-10-20 DMESS Krogh  Changes to use M77CON
	 *>> 1994-09-21 DMESS Krogh  Added CHGTYP code.
	 *>> 1994-09-08 DMESS Krogh  Added new matrix/vector capabilities.
	 *>> 1994-08-17 DMESS Krogh  Removed duplicate save statement.
	 *>> 1994-04-19 DMESS Krogh  Removed blank line from DMESS.
	 *>> 1993-05-14 DMESS Krogh  Changed TEXT to array of character strings.
	 *>> 1993-04-14 DMESS Krogh  Fixes for conversion to C. (C%% comments.)
	 *>> 1992-07-12 DMESS Krogh  Fixed so negative KDFDEF works.
	 *>> 1992-05-27 DMESS Krogh  Initialized LDFDEF in a data statement.
	 *>> 1992-05-14 DMESS Krogh  Put common blocks in save statement.
	 *>> 1992-04-28 DMESS Krogh  Corrected minor error in floating pt. format
	 *>> 1992-02-28 DMESS Krogh  Initial Code.
	 *
	 *--D replaces "?": ?MESS,?MESSXC
	 *
	 * Processes Messages -- Actions are controlled by MACT().  See
	 * comment is subroutine MESS.  This program is for the extra
	 * argument of type real.
	 *
	 * BUF    In common CMESSC, see MESS.
	 * DOLS   In common for intitialization, not used here.  See MESS.
	 * EUNIT  In common for intitialization, not used here.  See MESS.
	 * FDAT   Formal argument -- gives floating point data to print.
	 * FBIG   Largest magnitude of floating point number to output.
	 * FSMA   Smalles magnitude floating point number to be printed.
	 * FMTF   In common CMESSC, format for printing floating point number.
	 * FMTG   In common CMESSC, user format to use in place of FMTF.
	 * FMTSP  Format for printing sparse vectors.
	 * FOUT   Floating point number to be output.
	 * FSMA   Smallest postitive floating point number.
	 * ICOL   In common CMESSI, see MESS.
	 * ID     Number of decimal digits for floating point format statement.
	 * IDAT   Integer data -- passed to MESS.
	 * IVAR   In common CMESSI, see MESS.
	 * IWF    In common CMESSI, see MESS.
	 * IWG    In common CMESSI, see MESS.
	 * J      Temporary index.
	 * K      Temporary index.
	 * KSMA   Number of leading 0's in "F" format.  If < 0, -KSMA gives the
	 *    number of extra digits to the left of the decimal point.
	 *    KSMA depends on abs(smallest number printed).
	 * KBIG   Number of extra digits before the decimal point required by the
	 *    largest number to be printed if "F" format is used.
	 * KDF    In common CMESSI, see MESS.
	 * KDFDEF In common CMESSI, see MESS.
	 * KDIAG  In common CMESSI, not used here, see MESS.
	 * KEXE   Extra space required for E format.
	 * KF     In common CMESSI, see MESS.
	 * KLINE  In common CMESSI, see MESS.
	 * KSCRN  In common CMESSI, see MESS.
	 * KRES1  In common CMESSI, see MESS.
	 * KSPEC  In common CMESSI, see MESS.
	 * LASTER In common CMESSI, not used here, see MESS.
	 * LASTI  In common CMESSI, see MESS.
	 * LBUF   In common CMESSI, see MESS.
	 * LDFDEF Value of KDFDEF for this routine.  (Saved)
	 * LENBUF In common CMESSI, see MESS.
	 * LENLIN In common CMESSI, not used here, see MESS.
	 * LENTRY In common CMESSI, see MESS.
	 * LHEAD  In common CMESSI, not used here, see MESS.
	 * LINERR In common CMESSI, not used here, see MESS.
	 * LINMSG In common CMESSI, not used here, see MESS.
	 * LOCBEG In common CMESSI, see MESS.
	 * LPRINT In common CMESSI, not used here, see MESS.
	 * LSTOP  In common CMESSI, not used here, see MESS.
	 * LSTRT  In common CMESSI, see MESS.
	 * MACT   Formal argument, see MESS.
	 * MDAT   In common CMESSI, not used here, see MESS.
	 * MEMDA5 In common CMESSI, see MESS.
	 * MESS   Program called for most of the message processing.
	 * MPT    In common CMESSI, see MESS.
	 * MUNIT  In common CMESSI, not used here, see MESS.
	 * NCOL   In common CMESSI, see MESS.
	 * NDIM   In common CMESSI, see MESS.
	 * NEG    1 if any number is < 0, else it is 0.
	 * NFDAT  In common CMESSI, see MESS.
	 * NIDAT  In common CMESSI, not used here, see MESS. */
	/* NMDAT  In common CMESSI, not used here, see MESS.
	 * NTEXT  In common CMESSI, not used here, see MESS.
	 * OUNIT  In common CMESSI, not used here, see MESS.
	 * D1MACH External func. giving floating pt. info. about the environment.
	 * SUNIT  In common CMESSI, not used here, see MESS.
	 * TEXT   Formal argument, passed to MESS, see there.
	 * XARGOK In common CMESSI, see MESS.
	 * */
 void dmessxc(long int);
	/*c */
	/*++ CODE for .C. is active */
	/*++ END
	 *
	 * ************************** Data from common block ********************
	 *
	 * For comments on these variables, see the listing for MESS.
	 * */
 
 
 
	/* ************************* Start of Executable Code *******************
	 * */
	cmessi.xargok = TRUE;
	if (ldfdef == 0)
	{
		ldfdef = 1 - (long)( log10( DBL_EPSILON/FLT_RADIX ) );
	}
	cmessi.kdfdef = ldfdef;
	cmessi.kdf = cmessi.kdfdef;
L_10:
	mess( mact, text,text_s, idat );
	/*             4    5    6    7    8    9   10   11 */
	switch (cmessi.lentry - 3)
	{
		case 1: goto L_20;
		case 2: goto L_100;
		case 3: goto L_100;
		case 4: goto L_200;
		case 5: goto L_300;
		case 6: goto L_400;
		case 7: goto L_100;
		case 8: goto L_500;
	}
	cmessi.xargok = FALSE;
	ldfdef = cmessi.kdfdef;
	return;
	/*                                      Print from FDAT */
L_20:
	j = cmessi.lbuf + 1;
	fout = Fdat[cmessi.nfdat];
	cmessi.nfdat += 1;
	if (cmessi.kspec >= 8)
	{
		cmessi.lbuf += cmessi.iwg;
 messcc.lend = cmessi.lbuf;
 cmessc.buf[messcc.lend] = ' ';
 if ((j > 1) && (cmessc.buf[j-2] >= '0') &&
    (cmessc.buf[j-2] <= '9')) cmessc.buf[j++ - 1] = ' ';
 sprintf(&cmessc.buf[j-1], cmessc.fmtg, cmessi.iwg,
    messcc.lgprec, fout);
 if (cmessc.buf[messcc.lend] != 0) {messcc.lbeg=j; dmessxc(kexe);}
		goto L_10;
		/*         write (BUF(J:LBUF), FMTG) FOUT */
	}
	if (fout <= 0.e0)
	{
		if (fout == 0.e0)
		{
			Fdat[cmessi.nfdat - 1] = 0.e0;
			fout = 0.e0;
		}
		else
		{
			neg = 1;
		}
	}
	else if (fout > 0.e0)
	{
		neg = 0;
	}
	else
	{
		/*               Must be a Nan */
		neg = 0;
		fbig = 1.0;
		fsma = 1.0;
		cmessi.iwf = 2;
		goto L_40;
	}
 
	fbig = fabs( fout );
	fsma = fbig;
	cmessi.iwf = 2;
	/*                                      Get the format. */
L_40:
	;
	if (cmessi.kdf == 0)
		cmessi.kdf = cmessi.kdfdef;
	kexe = 0;
	if (fbig != 0.e0)
	{
		if (fsma == 0.e0)
			fsma = 1.e0;
		fbig *= 1.e0 + .5e0*powi(.1e0,labs( cmessi.kdf ));
		cmessi.iwf += neg;
		if (cmessi.kdf < 0)
		{
			ksma = 0;
		}
		else
		{
			ksma = -log10( fsma );
			if (fsma < 1.e0)
				ksma += 1;
		}
		kbig = log10( fbig );
		if (fbig < 1.e0)
		{
			kbig -= 1;
			if (fbig > 1.e0 - powi(.1e0,labs( cmessi.kdf - 1 )))
				kbig = 0;
		}
		/*         This is to get ininities out (at least with g77) */
		if ((kbig < -1000) || (kbig > 1000))
			kbig = 8;
		if ((ksma < -1000) || (ksma > 1000))
			ksma = 8;
		if (max( kbig, 0 ) + max( ksma, 0 ) >= 4)
		{
			/*               Want to use an "E" format */
			kexe = 3 + max( 0, (long)( log10( ( max( kbig, labs( ksma ) ) +
			 1.e-5 ) ) ) );
			if (cmessi.kdf < 0)
			{
				id = -cmessi.kdf;
			}
			else
			{
				id = cmessi.kdf - 1;
			}
			cmessi.iwf += id + kexe;
			/*++ CODE for ~.C. is inactive
			 *          if (LENTRY .eq. 10) IWF = IWF - 1
			 *          write (FMTF, '(''(1P,99(E'',I2,''.'',I2,''E'',I1,'':1X))'')')
			 *     1      IWF, ID, KEXE - 2
			 *++ CODE for .C. is active
			 * WATCOM C and others (?) man need an extra 1 here?? */
    strcpy(cmessc.fmtf, "%*.*E ");
			messcc.lfprec = id;
			/*++ END */
			goto L_60;
		}
	}
	else
	{
		ksma = 1;
		kbig = -1;
	}
	/*               Want to use an "F" format */
	if (cmessi.kdf < 0)
	{
		id = -cmessi.kdf;
	}
	else
	{
		id = cmessi.kdf + ksma - 1;
	}
	/*++ CODE for ~.C. is inactive
	 *      IWF = IWF + ID + max(KBIG, -1)
	 *      write (FMTF, '(''(0P,99(F'',I2,''.'',I2,'':1X))'')') IWF,ID
	 *++ CODE for .C. is active */
	cmessi.iwf += id + max( kbig, 0 );
    strcpy(cmessc.fmtf, "%*.*f ");
	messcc.lfprec = id;
	/*++ END */
L_60:
	if (cmessi.lentry != 4)
	{
		cmessi.iwf += 1;
		if (cmessi.lentry != 10)
			goto L_10;
		/*               Take care of setup for sparse vector */
		cmessi.imag = 0;
		for (j = cmessi.locbeg; j <= cmessi.lasti; j++)
		{
			cmessi.imag = max( labs( cmessi.imag ), Idat[j] );
		}
		messfi();
		/*  Format forms:     12345678901234567890   123456789012345678  1234567
		 *                    (1P,99(Edd.ddEd:1X))   (0P,99(Fxx.xx:1X))  (99Idd)
		 *++ CODE for ~.C. is inactive
		 *        if (FMTF(8:8) .eq. 'F') then
		 *          FMTSP=
		 *     1      '(99(' // FMTI(4:6) // ''') '',0P,' // FMTF(8:18)
		 *        else
		 *          FMTSP=
		 *     1     '(99(' // FMTI(4:6) // ''')'' ,1P,' // FMTF(8:20)
		 *        end if
		 *++ CODE for .C. is active
		 * Using cmessc.fmtf in place of fmtsp */
      if (cmessc.fmtf[4] == 'f') {
      strcpy(cmessc.fmtf, "%*ld) %*.*f ");
      kexe = 0;
      }
      else strcpy(cmessc.fmtf, "%*ld) %*.*E ");
      cmessi.iwf++;
		cmessi.iwf += cmessi.kdi + 1;
		/*++ END */
		goto L_10;
	}
 
	cmessi.lbuf += cmessi.iwf;
 messcc.lend = cmessi.lbuf;
 cmessc.buf[messcc.lend] = ' ';
 if ((j > 1) && (cmessc.buf[j-2] >= '0') &&
    (cmessc.buf[j-2] <= '9')) cmessc.buf[j++ - 1] = ' ';
 sprintf(&cmessc.buf[j-1], cmessc.fmtf, cmessi.iwf,
    messcc.lfprec, fout);
 if (cmessc.buf[messcc.lend] != 0) {messcc.lbeg=j; dmessxc(kexe);}
	goto L_10;
	/*      write (BUF(J:LBUF),FMTF) FOUT
	 *                                     Get format for a vector or matrix */
L_100:
	icol = 1;
	if (Fdat[cmessi.locbeg] < 0.e0)
	{
		neg = 1;
	}
	else if (Fdat[cmessi.locbeg] >= 0.e0)
	{
		neg = 0;
	}
	else
	{
		/*               Must be a Nan */
		neg = 0;
		fbig = 1.0;
		fsma = 1.0;
		goto L_110;
	}
 
	fbig = fabs( Fdat[cmessi.locbeg] );
	fsma = fbig;
L_110:
	for (j = cmessi.locbeg, _do0=DOCNT(j,cmessi.lasti,_do1 = cmessi.inc); _do0 > 0; j += _do1, _do0--)
	{
		if (Fdat[j] <= 0.e0)
		{
			if (Fdat[j] == 0.e0)
			{
				Fdat[j] = 0.e0;
			}
			else
			{
				neg = 1;
			}
		}
		fbig = fmax( fbig, fabs( Fdat[j] ) );
		if (fsma == 0.e0)
		{
			fsma = fabs( Fdat[j] );
		}
		else if (Fdat[j] != 0.e0)
		{
			fsma = fmin( fsma, fabs( Fdat[j] ) );
		}
	}
	if (cmessi.ncol != 0)
	{
		icol += 1;
		cmessi.locbeg += cmessi.ndim;
		cmessi.lasti += cmessi.ndim;
		if (icol <= cmessi.ncol)
			goto L_110;
	}
	cmessi.iwf = 2;
	goto L_40;
	/*                                    Floating point vector output */
L_200:
	;
 messcc.lend = cmessi.lstrt-1;
 neg = 0;
 for (j=cmessi.mpt; j<cmessi.mpt+cmessi.kline; j++){
   messcc.lbeg = messcc.lend;
   messcc.lend = messcc.lend + cmessi.iwf;
   if (kexe) {
     if (kexe == 5)
        neg = ((fabs(fdat[cmessi.inc*j-1]) < 1.e100)) ? -1: 0;
     else if (kexe ==3) neg = 1;
   }
   sprintf(&cmessc.buf[messcc.lbeg], cmessc.fmtf,
    cmessi.iwf+neg, messcc.lfprec, fdat[cmessi.inc*j-1]);
   if ((kexe == 3) || ((kexe == 5) && neg)) dmessxc(kexe); }
	cmessi.mpt += cmessi.kline*cmessi.inc;
	/*      write(BUF(LSTRT:LBUF),FMTF)(FDAT(K),K=MPT,MPT+INC*(KLINE-1),INC) */
 
 
	/*      print '(/A/)', BUF(1:LBUF) */
 
	goto L_10;
	/*                                    Floating point matrix output */
L_300:
	;
 messcc.lend = cmessi.lstrt-1;
 neg = 0;
 for (j=cmessi.mpt; j<=cmessi.lasti; j+=cmessi.ndim){
    messcc.lbeg = messcc.lend;
    messcc.lend = messcc.lend + cmessi.iwf;
   if (kexe) {
     if (kexe == 5) neg = ((fabs(fdat[j-1]) < 1.e100)) ? -1: 0;
     else if (kexe ==3) neg = 1;
   }
    sprintf(&cmessc.buf[messcc.lbeg],
       cmessc.fmtf, cmessi.iwf+neg, messcc.lfprec, fdat[j-1]);
    if ((kexe == 3) || ((kexe == 5) && neg)) dmessxc(kexe); }
	goto L_10;
	/*CC%%    if ((messcc.lbeg > 1) && (cmessc.buf[messcc.lbeg-1] >= '0') &&
	 *C%%       (cmessc.buf[messcc.lbeg-1] <= '9'))
	 *C%%       cmessc.buf[messcc.lbeg++] = ' ';
	 *      write (BUF(LSTRT:LBUF), FMTF) (FDAT(K), K = MPT, LASTI, NDIM)
	 *                                    Table output */
L_400:
	;
 messcc.lend = cmessi.lstrt-1;
 neg=0;
 for (j=cmessi.mpt; j<cmessi.mpt+cmessi.kline; j++){
    messcc.lbeg = messcc.lend;
    messcc.lend = messcc.lend + cmessi.iwf;
    sprintf(&cmessc.buf[messcc.lbeg], cmessc.fmtf,
       cmessi.iwf+neg, messcc.lfprec, fdat[j-1]); }
	goto L_10;
	/*CC%%    if ((messcc.lbeg > 1) && (cmessc.buf[messcc.lbeg-1] >= '0') &&
	 *C%%       (cmessc.buf[messcc.lbeg-1] <= '9'))
	 *C%%       cmessc.buf[messcc.lbeg++] = ' ';
	 *      write (BUF(LSTRT:LBUF), FMTF) (FDAT(K), K = MPT, MPT+KLINE-1) */
 
 
	/*                                   Sparse vector output */
L_500:
	;
  messcc.lend = -1;
  neg = 0;
  for (j=cmessi.mpt; j<cmessi.mpt+cmessi.kline; j++) {
    messcc.lbeg = messcc.lend + 1;
     messcc.lend = messcc.lend + cmessi.iwf;
   if (kexe) {
     if (kexe == 5) neg = ((fabs(fdat[j-1]) < 1.e100)) ? -1: 0;
     else if (kexe == 3) neg = 1;
   }
   sprintf(&cmessc.buf[messcc.lbeg], cmessc.fmtf, cmessi.kdi,
     idat[j-1],cmessi.iwf-cmessi.kdi-2+neg,messcc.lfprec,fdat[j-1]);
     if ((kexe == 3) || ((kexe == 5) && neg)) dmessxc(kexe); }
	cmessi.mpt += cmessi.kline;
	/*      write (BUF(1:LBUF), FMTSP) (IDAT(K),FDAT(K),K=MPT,MPT+KLINE-1) */
	goto L_10;
 
#undef	TEXT
} /* end of function */
 
  void dmessxc(long int kexe)
{
  /* Adjust for lack of control on digits in exponent */
  char c;
 if (cmessc.fmtf[4] == 'f') return;
 if (kexe == 4) return;
 if (kexe == 3) { // Should only be one digit in the exponent
   cmessc.buf[messcc.lend-1] = cmessc.buf[messcc.lend];
   cmessc.buf[messcc.lend] = ' ';
 }
 else { // Should be at least 3 digits in the exponent.
   c =cmessc.buf[messcc.lend-4];
   if ((c < '0') || (c > '9')) {
     cmessc.buf[messcc.lend-1] = cmessc.buf[messcc.lend-2];
     cmessc.buf[messcc.lend-2] = cmessc.buf[messcc.lend-3];
     cmessc.buf[messcc.lend-3] = '0';
     cmessc.buf[messcc.lend] = ' ';
   }
 }
 return;
} /* end of function */