/*Translated by FOR_C, v3.4.2 (-), on 07/09/115 at 08:30:06 */
/*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 "drotmg.h"
#include <stdlib.h>
void /*FUNCTION*/ drotmg(
double *d1,
double *d2,
double *x1,
double y1,
double param[])
{
	double h11, h12, h21, h22, p1, p2, pflag, q1, q2, temp, u;
	static double gam = 4096.e0;
	static double gamsq = 16777216.e0;
	static double rgamsq = 5.9604645e-8;
		/* OFFSET Vectors w/subscript range: 1 to dimension */
	double *const Param = &param[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.
	 *>> 2006-06-07 DROTMG Krogh  Removed arithmetic ifs
	 *>> 1999-12-30 DROTMG Krogh  Big reorg., no more assigned goto's.
	 *>> 1999-12-22 DROTMG Krogh  Declared IGO.
	 *>> 1994-10-20 DROTMG Krogh  Changes to use M77CON
	 *>> 1994-04-19 DROTMG Krogh   Converted to use generic intrinsics.
	 *>> 1985-08-02 DROTMG Lawson  Initial code.
	 *--D replaces "?": ?ROTMG
	 *
	 *     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
	 *     THE SECOND COMPONENT OF THE 2-VECTOR  (SQRT(D1)*X1,SQRT(D2)*
	 *     Y1)**T.
	 *     WITH PARAM(1)=PFLAG, H HAS ONE OF THE FOLLOWING FORMS..
	 *
	 *     PFLAG=-1.D0     PFLAG=0.D0        PFLAG=1.D0     PFLAG=-2.D0
	 *
	 *       (H11  H12)    (1.D0  H12)    (H11  1.D0)    (1.D0  0.D0)
	 *     H=(        )    (         )    (         )    (          )
	 *       (H21  H22),   (H21  1.D0),   (-1.D0 H22),   (0.D0  1.D0).
	 *     LOCATIONS 2-5 OF PARAM CONTAIN H11, H21, H12, AND H22
	 *     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
	 *     VALUE OF PARAM(1) ARE NOT STORED IN PARAM.)
	 *
	 *     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
	 *     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
	 *     OF D1 AND D2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
	 * */
 
	if (*d1 < 0.e0)
		goto L_210;
	p2 = *d2*y1;
	if (p2 == 0.e0)
	{
		pflag = -2.e0;
		goto L_260;
	}
	/*     Regular case */
	p1 = *d1**x1;
	q2 = p2*y1;
	q1 = p1**x1;
	if (fabs( q1 ) > fabs( q2 ))
	{
		h21 = -y1/ *x1;
		h12 = p2/p1;
		u = 1.e0 - h12*h21;
		if (u <= 0.e0)
			goto L_210;
		pflag = 0.e0;
		*d1 /= u;
		*d2 /= u;
		*x1 *= u;
	}
	else
	{
		if (q2 < 0.e0)
			goto L_210;
		pflag = 1.e0;
		h11 = p1/p2;
		h22 = *x1/y1;
		u = 1.e0 + h11*h22;
		temp = *d2/u;
		*d2 = *d1/u;
		*d1 = temp;
		*x1 = y1*u;
	}
 
	/*     Scale Check */
L_100:
	if (*d1 <= *d2)
	{
		if (*d1 <= rgamsq)
		{
			if (*d1 != 0.e0)
			{
				if (pflag >= 0.e0)
					goto L_150;
				*d1 *= SQ(gam);
				*x1 /= gam;
				h11 /= gam;
				h12 /= gam;
				goto L_100;
			}
		}
		if (fabs( *d2 ) < gamsq)
			goto L_220;
		if (pflag >= 0.e0)
			goto L_150;
		*d2 = *d2/SQ(gam);
		h21 *= gam;
		h22 *= gam;
		goto L_100;
	}
	else
	{
		if (fabs( *d2 ) <= rgamsq)
		{
			if (pflag >= 0.e0)
				goto L_150;
			*d2 *= SQ(gam);
			h21 /= gam;
			h22 /= gam;
			goto L_100;
		}
		if (*d1 < gamsq)
			goto L_220;
		if (pflag >= 0.e0)
			goto L_150;
		*d1 = *d1/SQ(gam);
		*x1 *= gam;
		h11 *= gam;
		h12 *= gam;
		goto L_100;
	}
 
	/*     Fix H */
L_150:
	if (pflag == 0.e0)
	{
		h11 = 1.e0;
		h22 = 1.e0;
	}
	else
	{
		h21 = -1.e0;
		h12 = 1.e0;
	}
	pflag = -1.e0;
	goto L_100;
 
	/*     Zero H, D, and X1 */
L_210:
	pflag = -1.e0;
	h11 = 0.e0;
	h12 = 0.e0;
	h21 = 0.e0;
	h22 = 0.e0;
 
	*d1 = 0.e0;
	*d2 = 0.e0;
	*x1 = 0.e0;
 
	/*     Return */
L_220:
	;
	if (pflag == 0.e0)
	{
		Param[3] = h21;
		Param[4] = h12;
	}
	else if (pflag > 0.e0)
	{
 
		Param[2] = h11;
		Param[5] = h22;
	}
	else
	{
		Param[2] = h11;
		Param[3] = h21;
		Param[4] = h12;
		Param[5] = h22;
	}
L_260:
	Param[1] = pflag;
	return;
} /* end of function */