/* tacov.f -- translated by f2c (version 20000817).
   You must link the resulting object file with the libraries:
	-lf2c -lm   (in that order)
*/

#include "f2c.h"

/* Common Block Declarations */

struct {
    integer inx;
    real c1rx, c2rx, rmin, rmax, cl1r;
} curve_;

#define curve_1 curve_

/* Table of constant values */

static doublereal c_b7 = 1.;
static doublereal c_b9 = 360.;

/* ----------------------------------------------------------------------- */
/*       FILE T_CONV */
/*       SUBROUTINE T_CONV(EI,AKI,EF,AKF,QHKL,EN,HX,HY,HZ,IF1,IF2,LDK,LDH,LDF */
/*       1       LPA,DM,DA,HELM,F1H,F1V,F2H,F2V,F,IFX,ISS,ISM,ISA, */
/*       2       T_A,T_RM,T_ALM,LDRA,LDR_RM,LDR_ALM,P_IH,C_IH,IER) */
/*       SUBROUTINE EX_CASE(DX,ISX,AKX,AX1,AX2,RX,ALX,IER) */
/*       SUBROUTINE SAM_CASE(QT,QM,QS,AKI,AKF,AX3,AX4,ISS,IER) */
/*       SUBROUTINE HELM_CASE(HX,HY,HZ,P_IH,AKI,AKF,A4,QM,HELM,IER) */
/*       SUBROUTINE FLIP_CASE(IF1,IF2,P_IH,F1V,F1H,F2V,F2H,AKI,AKF,IER) */
/* ----------------------------------------------------------------------- */
/* Subroutine */ int t_conv__(real *ei, real *aki, real *ef, real *akf, real *
	qhkl, real *en, real *hx, real *hy, real *hz, integer *if1, integer *
	if2, logical *ldk, logical *ldh, logical *ldf, logical *lpa, real *dm,
	 real *da, real *helm, real *f1h, real *f1v, real *f2h, real *f2v, 
	real *f, integer *ifx, integer *iss, integer *ism, integer *isa, real 
	*t_a__, real *t_rm__, real *t_alm__, real *qm, logical *ldra, logical 
	*ldr_rm__, logical *ldr_alm__, real *p_ih__, real *c_ih__, integer *
	ier)
{
    /* System generated locals */
    doublereal d__1;

    /* Builtin functions */
    double sqrt(doublereal);

    /* Local variables */
    static doublereal edef[2], dakf, daki;
    static integer imod;
    extern /* Subroutine */ int sam_case__(doublereal *, doublereal *, 
	    doublereal *, doublereal *, doublereal *, doublereal *, 
	    doublereal *, integer *, integer *);
    static integer i__;
    static doublereal akdef[2];
    extern /* Subroutine */ int helm_case__(real *, real *, real *, real *, 
	    real *, real *, real *, doublereal *, real *, real *, integer *);
    static doublereal dqhkl[3];
    extern /* Subroutine */ int flip_case__(integer *, integer *, real *, 
	    real *, real *, real *, real *, real *, real *, integer *);
    static logical lmoan[2];
    static doublereal a1, a2, a3, a4, a5, a6;
    static integer id;
    static doublereal ra;
    extern /* Subroutine */ int rl2spv_(doublereal *, doublereal *, 
	    doublereal *, doublereal *, integer *);
    static integer iq;
    static doublereal rm;
    static logical lqhkle;
    extern /* Subroutine */ int erreso_(integer *, integer *);
    static doublereal dda, ala, def, dei, ddm, alm, dqm;
    extern /* Subroutine */ int ex_case__(doublereal *, integer *, doublereal 
	    *, doublereal *, doublereal *, doublereal *, doublereal *, 
	    integer *);
    static doublereal dqt[3], dqs;

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

/*       INPUT */
/*       EI,AKI,EF,AKF,QHKL,EN,HX,HY,HZ : POTENTIAL TARGETS */
/* 	IF1,IF2 Status of flippers On (1) Off (0) */
/*       LDK(8)          LOGICAL INDICATING IF (ENERGY,K OR Q) ARE DRIVEN */
/*       LDH,LDF         LOGICAL INDICATING IF (HX,HY,HZ) OR (F1,F2) ARE DRIVEN */

/*       configuration of the machine */
/*       LPA             LOGICAL  TRUE IF MACHINE IN POLARIZATION MODE */
/*       DM,DA,HELM,F1H,F1V,F2H,F2V,F,IFX,ISS,ISM,ISA,QM (F ENERGY UNIT) */

/*       OUTPUT */
/*       T_A             TARGETS OF ANGLES A1-A6 */
/*       T_RM,T_ALM      TARGETS OF RM ,LM */
/*       QM                      TARGETS OF QM */
/*       LDRA                    LOGICAL INDICATING WHICH ANGLES ARE TO BE DRIVEN */
/*       LDR_RM,LDR_ALM  LOGICAL INDICATING IF RM OR ALM ARE TO BE DRIVEN */
/*       P_IH    TARGETS OF CURRENTS FOR FLIPPERS AND HELMOTZ (8 CURRENTS) */
/*       C_IH    CONVERSION FACTORS FOR HELMOTZ (4 CURRENTS) */

/*       SPECIAL OUTPUTS */
/*       TARGET OF EI(EF) IS UPDATED IS KI(KF) IS DRIVEN */
/*       TARGET OF VARIABLE ENERGY IS UPDATED IF EN IS DRIVEN */
/* ----------------------------------------------------------------------- */
/* ----------------------------------------------------------------------- */
/*       PASSED PARAMETERS */
/* ----------------------------------------------------------------------- */
/*        LOCAL VARIABLES */

/* ----------------------------------------------------------------------- */
/*       SET UP */
/*       IMOD  INDEX FOR ERROR TREATMENAT BY ERRESO */
/*       LDQHKLE : LOGICAL INDICATING THAT WE ARE DEALING WITH A MOVE */
/*       IN RECIPROCICAL SPACE */
/*       WE REMAP THE ENERGY PB AS FIXED ENERGY IN EDEF(1) */
/*       AND VARIABLE ENERGY IN EDEF(2) */
/*       IF ISA IS NUL  SET IFX TO 1 AND PUT EF,KF, EQUAL TO EI,KI */

    /* Parameter adjustments */
    --c_ih__;
    --p_ih__;
    --ldra;
    --t_a__;
    --ldk;
    --qhkl;

    /* Function Body */
    imod = 3;
    ddm = *dm;
    dda = *da;
    for (i__ = 1; i__ <= 2; ++i__) {
	lmoan[i__ - 1] = FALSE_;
    }
    lqhkle = FALSE_;
    for (iq = 5; iq <= 8; ++iq) {
	lqhkle = lqhkle || ldk[iq];
    }
    daki = *aki;
    dakf = *akf;
    if (*isa == 0) {
	*ifx = 1;
    }
    edef[*ifx - 1] = *ei;
    akdef[*ifx - 1] = *aki;
    edef[3 - *ifx - 1] = *ef;
    akdef[3 - *ifx - 1] = *akf;
    if (*isa == 0) {
	edef[1] = edef[0];
	akdef[1] = akdef[0];
	ldk[3] = TRUE_;
	ldk[4] = TRUE_;
	t_a__[5] = 0.f;
	t_a__[6] = 0.f;
	ldra[5] = TRUE_;
	ldra[6] = TRUE_;
    }
/* ----------------------------------------------------------------------- */
/*       FIRST TAKE IN ACCOUNT THE FIXED ENERGY PB */

    if (ldk[(*ifx << 1) - 1] || ldk[*ifx * 2]) {
	lmoan[*ifx - 1] = TRUE_;
	if (ldk[(*ifx << 1) - 1]) {
	    *ier = 1;
	    if (edef[0] < .1) {
		goto L999;
	    }
	    *ier = 0;
	    akdef[0] = sqrt(edef[0] / *f);
	} else {
	    *ier = 1;
	    if (akdef[0] < .1) {
		goto L999;
	    }
	    *ier = 0;
/* Computing 2nd power */
	    d__1 = akdef[0];
	    edef[0] = *f * (d__1 * d__1);
	}
    }
/* ----------------------------------------------------------------------- */
/*       NOW TAKE IN ACCOUNT THE VARIABLE ENERGY PB */
/*       VARIABLE ENERGUY IS DRIVEN EITHER EXPLICITLY */
/*       E.G. BY DRIVING EI OR KI WITH IFX=2 */
/*        ( AND WE MUST CALCULATE EN FROM EVAR) */
/*       THE RULE IS : EI=EF+EN : EN IS THE ENERGY LOSS OF NEUTRONS */
/*       OR ENERGY GAIN OF SAMPLE */
/*       OR IMPLICITLY  BY DRIVING THE TRANSFERED ENERGY EN */
/*        ( AND WE MUST CALCULATE EVAR FROM EN) */
/*       IF KI IS CONSTANT USE THE CURRENT VALUE CONTAINED IN POSN ARRAY */
/*       TO CALCULATE THE NON-"CONSTANT" K. */
/*       IF KF IS CONSTANT USE ALWAYS THE VALUE IN TARGET AND */
/*        DO A DRIVE OF KF TO KEEP A5/A6 IN RIGHT POSITION */

    if (ldk[5 - (*ifx << 1)] || ldk[6 - (*ifx << 1)]) {
	lmoan[3 - *ifx - 1] = TRUE_;
	if (ldk[5 - (*ifx << 1)]) {
	    *ier = 1;
	    if (edef[1] < 1e-4) {
		goto L999;
	    }
	    *ier = 0;
	    akdef[1] = sqrt(edef[1] / *f);
	} else {
	    *ier = 1;
	    if (akdef[1] < 1e-4) {
		goto L999;
	    }
	    *ier = 0;
/* Computing 2nd power */
	    d__1 = akdef[1];
	    edef[1] = *f * (d__1 * d__1);
	}
	*en = (3 - (*ifx << 1)) * (edef[0] - edef[1]);
    } else if (lqhkle) {
	lmoan[3 - *ifx - 1] = TRUE_;
	edef[1] = edef[0] + ((*ifx << 1) - 3) * *en;
	*ier = 1;
	if (edef[1] < 1e-4) {
	    goto L999;
	}
	*ier = 0;
	akdef[1] = sqrt(edef[1] / *f);
    }
/* ----------------------------------------------------------------------- */
/*       CALCULATE MONOCHROMATOR AND ANALYSER ANGLES */

    if (lmoan[0]) {
	dei = edef[*ifx - 1];
	daki = akdef[*ifx - 1];
	ex_case__(&ddm, ism, &daki, &a1, &a2, &rm, &alm, ier);
	if (*ier == 0) {
	    *aki = daki;
	    *ei = dei;
	    t_a__[1] = a1;
	    t_a__[2] = a2;
	    *t_rm__ = rm;
	    *t_alm__ = alm;
	    ldra[1] = TRUE_;
	    ldra[2] = TRUE_;
	    *ldr_rm__ = TRUE_;
	    *ldr_alm__ = TRUE_;
	} else {
	    goto L999;
	}
    }
    if (lmoan[1]) {
	def = edef[3 - *ifx - 1];
	dakf = akdef[3 - *ifx - 1];
	ex_case__(&dda, isa, &dakf, &a5, &a6, &ra, &ala, ier);
	if (*ier == 0) {
	    *akf = dakf;
	    *ef = def;
	    t_a__[5] = a5;
	    t_a__[6] = a6;
	    ldra[5] = TRUE_;
	    ldra[6] = TRUE_;
	} else {
	    goto L999;
	}
    }
/* ----------------------------------------------------------------------- */
/*       USE (QH,QK,QL) TO CALCULATE A3 AND A4 */
/*       CALCULATE Q1 AND Q2 IN SCATTERING PLANE */

    imod = 2;
    if (lqhkle) {
	for (id = 1; id <= 3; ++id) {
	    dqhkl[id - 1] = qhkl[id];
	}
	rl2spv_(dqhkl, dqt, &dqm, &dqs, ier);
	if (*ier != 0) {
	    goto L999;
	}
	sam_case__(dqt, &dqm, &dqs, &daki, &dakf, &a3, &a4, iss, ier);
	if (*ier == 0) {
	    t_a__[3] = a3;
	    t_a__[4] = a4;
	    ldra[3] = TRUE_;
	    ldra[4] = TRUE_;
	    *qm = dqm;
	} else {
	    goto L999;
	}
    }
/* ----------------------------------------------------------------------- */
/*        DEAL WITH FLIPPERS AND HELMOTZ COILS IF LPA */

    if (*lpa && (lmoan[0] || lmoan[1])) {
	if (*ldf) {
	    flip_case__(if1, if2, &p_ih__[1], f1v, f1h, f2v, f2h, aki, akf, 
		    ier);
	}
	if (*ldh) {
	    helm_case__(hx, hy, hz, &p_ih__[1], &c_ih__[1], aki, akf, &a4, qm,
		     helm, ier);
	}
    }
/* ----------------------------------------------------------------------- */
L999:
    if (*ier != 0) {
	erreso_(&imod, ier);
    }
    return 0;
} /* t_conv__ */

/* Subroutine */ int ex_case__(doublereal *dx, integer *isx, doublereal *akx, 
	doublereal *ax1, doublereal *ax2, doublereal *rx, doublereal *alx, 
	integer *ier)
{
    /* System generated locals */
    doublereal d__1, d__2;

    /* Builtin functions */
    double asin(doublereal), sin(doublereal), cos(doublereal), sqrt(
	    doublereal);

    /* Local variables */
    static doublereal dcl1r, dc1rx, dc2rx, drmin, drmax, arg;

/* ----------------------------------------------------------------------- */
/*        CALCULATE  ANGLES ON MONO/ANALYSER */
/*       CALCULATE AX1  AX2 */
/*       CALCULATE RX LX MONO CURVATURE AND LM FOR IN8 */

/*       INPUT */
/*       DX      D-SPACINGS */
/*       ISX     SENS OF SCATTERING ON CRYSTAL */
/*       AKX     TARGET OF MOMENTUM */
/*       OUTPUT */
/*       AX1 AX2  THETA 2*THETA ANGLES */
/*       RX      MONO OR ANALYSER CURVATURE */
/*       ALX     SPECIAL TRANSLATION FOR IN8 */
/*       IER */
/*        1       ' KI OR KF CANNOT BE OBTAINED CHECK D-SPACINGS', */
/*        2       ' KI OR KF TOO SMALL', */
/*        3       ' KI OR KF TOO BIG', */

/* ----------------------------------------------------------------------- */
/* 	Values of parameters */

/* 	INX=1 IN8 , INX=0 others instruments */
/* 	C1RX C2RX constants values to calculate RM on all instruments */
/* 	RMIN, RMAX min max on RNM */
/* 	CL1R constant value to calculate LM for IN8 */

/* ----------------------------------------------------------------------- */
/* ----------------------------------------------------------------------- */
/*       PASSED PARAMETERS */
/* ----------------------------------------------------------------------- */
/*       LOCAL VAR */
/* ----------------------------------------------------------------------- */
/*       INIT AND TEST */

    *ier = 0;
    dc1rx = curve_1.c1rx;
    dc2rx = curve_1.c2rx;
    drmin = curve_1.rmin;
    drmax = curve_1.rmax;
    dcl1r = curve_1.cl1r;
    if (*dx < .1f) {
	*ier = 1;
    }
    if (*akx < .1f) {
	*ier = 2;
    }
    arg = 3.1415926535897932384626433832795f / (*dx * *akx);
    if (abs(arg) > 1.f) {
	*ier = 3;
    }
    if (*ier != 0) {
	goto L999;
    }
/* ----------------------------------------------------------------------- */
/*       CALCULATION OF THE TWO ANGLES */

    *ax1 = asin(arg) * *isx * 57.29577951308232087679815481410517f;
    *ax2 = *ax1 * 2.;
/* ----------------------------------------------------------------------- */
/*        CALCULATION OF MONO CURVATURE RM OR ANALYSER CURVATURE RA */
/*       STANDARD LAW IS  C1RX+C2RX/SIN(A1/RD) */
/*       C1RX AND C2RX ARE CONSTANTS DEPENDING ON MONO AND MACHINES */

/*        C1RX=.47 */
/*        C2RX=.244 */
/*        RMIN=0. */
/*       RMAX=20. */
/* 	IN1/IN3/IN12/IN14/IN20 CASE */
    if (curve_1.inx == 0) {
/* Computing MIN */
/* Computing MAX */
	d__2 = dc1rx + dc2rx / sin(abs(*ax1) / 
		57.29577951308232087679815481410517f);
	d__1 = max(d__2,drmin);
	*rx = min(d__1,drmax);
    } else {
/* 	IN8 CASE */
	*alx = dcl1r / sin(*ax2 / 57.29577951308232087679815481410517f) * cos(
		*ax2 / 57.29577951308232087679815481410517f);
	*rx = dc2rx * sqrt(sin(*ax2 / 57.29577951308232087679815481410517f)) 
		- dc1rx;
    }
/* ----------------------------------------------------------------------- */
L999:
    return 0;
} /* ex_case__ */

/* ========================================================================= */
/* Subroutine */ int sam_case__(doublereal *qt, doublereal *qm, doublereal *
	qs, doublereal *aki, doublereal *akf, doublereal *ax3, doublereal *
	ax4, integer *iss, integer *ier)
{
    /* System generated locals */
    doublereal d__1, d__2;

    /* Builtin functions */
    double acos(doublereal), atan2(doublereal, doublereal), d_sign(doublereal 
	    *, doublereal *), d_mod(doublereal *, doublereal *);

    /* Local variables */
    static doublereal arg, sax3;

/* ----------------------------------------------------------------------- */
/*               DEAL WITH SAMPLE ANGLES CALCULATION FROM Q VERTOR IN C-N PLANE */
/*       CALCULATE A3 AND A4 */
/*       INPUT */
/*       QT      Q-VECTOR IN SCATTERING PLANE */
/*       QM,QS   Q MODULUS AND QMODULUS SQUARED */
/*       AKI,AKF MOMEMTA ON MONO AND ANYLSER */
/*       ISS             SENS OF SCATTERING ON SAMPLE */

/*       OUTPUT */
/*       AX3 AX4         ANGLES ON SAMPLES */
/*       IER SAME ERROR AS RL2SPV */
/*       IER */
/*        1       ' MATRIX S NOT OK', */
/*        2       ' Q NOT IN SCATTERING PLANE', */
/*        3       ' Q MODULUS TOO SMALL', */
/*        4       ' Q MODULUS TOO BIG', */
/* ----------------------------------------------------------------------- */
/* ----------------------------------------------------------------------- */
/*       PASSED PARAMETERS */
/* ----------------------------------------------------------------------- */
/*       INIT AND TEST */

    /* Parameter adjustments */
    --qt;

    /* Function Body */
    *ier = 0;
    if (abs(*qs) < 1e-6 || abs(*qm) < .001) {
	*ier = 3;
	goto L999;
    }
/* ----------------------------------------------------------------------- */
/*       CALCULATE A3 AND MOVE IT INTHE -180 ,+180 INTERVAL */

/* Computing 2nd power */
    d__1 = *aki;
/* Computing 2nd power */
    d__2 = *akf;
    arg = (d__1 * d__1 + d__2 * d__2 - *qs) / (*aki * 2. * *akf);
    if (abs(arg) > 1.) {
	*ier = 4;
	goto L999;
    } else {
	*ax4 = acos(arg) * *iss * 57.29577951308232087679815481410517;
    }
/* Computing 2nd power */
    d__1 = *akf;
/* Computing 2nd power */
    d__2 = *aki;
    *ax3 = (-atan2(qt[2], qt[1]) - acos((d__1 * d__1 - *qs - d__2 * d__2) / (*
	    qm * -2. * *aki)) * d_sign(&c_b7, ax4)) * 
	    57.29577951308232087679815481410517;
    sax3 = d_sign(&c_b7, ax3);
    d__1 = *ax3 + sax3 * 180.;
    *ax3 = d_mod(&d__1, &c_b9) - sax3 * 180.;

/*       IF(LPLATE) AX3=-ATAN(SIN(AX4/RD)/(LSA*TAN(AX5/RD)/(ALMS*C */
/*       1       TAN(AX1/RD))*(AKI/KF)**2-COS(AX4/RD)))*RD       !PLATE FOCALIZATION OPTION */
/*       IF(AXX3.GT.180.D0) AX3=AX3-360.D0 */
/*       IF( A3.LT.-180.D0) AX3=AX3+360.D0 */
/*       IF(LPLATE.AND.A3.GT.0.0) AX3=AX3-180 */
/* C----------------------------------------------------------------------- */
L999:
    return 0;
} /* sam_case__ */

/* ============================================================================ */
/* Subroutine */ int helm_case__(real *hx, real *hy, real *hz, real *t_ih__, 
	real *c_ih__, real *aki, real *akf, doublereal *a4, real *qm, real *
	helm, integer *ier)
{
    /* System generated locals */
    real r__1, r__2;

    /* Builtin functions */
    double cos(doublereal), sin(doublereal), atan2(doublereal, doublereal), 
	    sqrt(doublereal);

    /* Local variables */
    static real hrad, hdir, qpar, hdir2, qperp;
    static integer ic;
    static real phi;

/* ----------------------------------------------------------------------- */
/*               DEAL WITH HELMOTZ COIL FIELD CALCULATIONS */
/*       CALCULATE HX HY HZ */
/* ----------------------------------------------------------------------- */
/* ----------------------------------------------------------------------- */
/*       PASSED PARAMETERS */
/* ----------------------------------------------------------------------- */
/*       INIT AND TEST */

    /* Parameter adjustments */
    --c_ih__;
    --t_ih__;

    /* Function Body */
    *ier = 1;
    if (dabs(*qm) < 1e-4f) {
	goto L999;
    }
    *ier = 0;
    for (ic = 1; ic <= 4; ++ic) {
	if (c_ih__[ic] < 1e-4f) {
	    *ier = 2;
	}
    }
    if (*ier != 0) {
	goto L999;
    }
/* ----------------------------------------------------------------------- */
/*       CALCULATE MODULE AND ANGLES OF IN PLANE FIELD H */
/*       PHI                     !ANGLE BETWEEN Q AND KI */
/*       HRAD            !RADIAL COMP. OF H */
/*       HDIR            !DIRECTION OF H (IN RADIANS) */
/*       HDIR2           !ANGLE BETWEEN FIELD AND AXE OF COIL 1 */

    qpar = *aki - *akf * cos(*a4 / 57.29577951308232087679815481410517f);
    qperp = *akf * sin(*a4 / 57.29577951308232087679815481410517f);
    phi = atan2(qpar, qperp);
/* Computing 2nd power */
    r__1 = *hx;
/* Computing 2nd power */
    r__2 = *hy;
    hrad = sqrt(r__1 * r__1 + r__2 * r__2);
    if (hrad > 1e-4f) {
	hdir = atan2(*hy, *hx);
    }
    hdir2 = phi + hdir + *helm / 57.29577951308232087679815481410517f + 
	    1.5707963267948966f;
/* ----------------------------------------------------------------------- */
/*               !CALC CURRENTS */
/*               !POSITION OF PSP FOR COIL I */

    for (ic = 1; ic <= 3; ++ic) {
	t_ih__[ic + 4] = cos(hdir2 + (ic - 1) * 2.f * 
		3.1415926535897932384626433832795f / 3.f) * hrad / c_ih__[ic] 
		/ 1.5f;
    }
    t_ih__[8] = *hz / c_ih__[4];
/* ----------------------------------------------------------------------- */
L999:
    return 0;
} /* helm_case__ */

/* Subroutine */ int flip_case__(integer *if1, integer *if2, real *t_ih__, 
	real *f1v, real *f1h, real *f2v, real *f2h, real *aki, real *akf, 
	integer *ier)
{
/* ----------------------------------------------------------------------- */
/*               DEAL WITH FLIPPER COIL  CALCULATIONS */
/*       CALCULATE P_IF CURRENTS FOR THE TWO FLIPPERS */
/* ----------------------------------------------------------------------- */
/*       PASSED PARAMETERS */
/* ----------------------------------------------------------------------- */
/*       INIT AND TEST */

    /* Parameter adjustments */
    --t_ih__;

    /* Function Body */
    *ier = 0;
/* ----------------------------------------------------------------------- */

    if (*if1 == 1) {
	t_ih__[1] = *f1v;
	t_ih__[2] = *aki * *f1h;
    } else {
	t_ih__[1] = 0.f;
	t_ih__[2] = 0.f;
    }
    if (*if2 == 1) {
	t_ih__[3] = *f2v;
	t_ih__[4] = *akf * *f2h;
    } else {
	t_ih__[3] = 0.f;
	t_ih__[4] = 0.f;
    }
/* ----------------------------------------------------------------------- */
/* L999: */
    return 0;
} /* flip_case__ */