- Adapted indenation to new agreed upon system
- Added support for second generation scriptcontext based counter
This commit is contained in:
koennecke
710
tacov.c
710
tacov.c
@@ -8,8 +8,8 @@
|
||||
/* Common Block Declarations */
|
||||
|
||||
struct {
|
||||
integer inx;
|
||||
real c1rx, c2rx, rmin, rmax, cl1r;
|
||||
integer inx;
|
||||
real c1rx, c2rx, rmin, rmax, cl1r;
|
||||
} curve_;
|
||||
|
||||
#define curve_1 curve_
|
||||
@@ -29,49 +29,61 @@ static doublereal c_b9 = 360.;
|
||||
/* 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)
|
||||
/* 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;
|
||||
/* System generated locals */
|
||||
doublereal d__1;
|
||||
|
||||
/* Builtin functions */
|
||||
double sqrt(doublereal);
|
||||
/* 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;
|
||||
/* 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;
|
||||
|
||||
/* ----------------------------------------------------------------------- */
|
||||
|
||||
@@ -112,67 +124,67 @@ static doublereal c_b9 = 360.;
|
||||
/* 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;
|
||||
/* 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_;
|
||||
}
|
||||
/* 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;
|
||||
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);
|
||||
}
|
||||
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 */
|
||||
@@ -187,131 +199,132 @@ static doublereal c_b9 = 360.;
|
||||
/* 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;
|
||||
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);
|
||||
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[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;
|
||||
}
|
||||
}
|
||||
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;
|
||||
}
|
||||
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);
|
||||
}
|
||||
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__ */
|
||||
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)
|
||||
/* 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;
|
||||
/* System generated locals */
|
||||
doublereal d__1, d__2;
|
||||
|
||||
/* Builtin functions */
|
||||
double asin(doublereal), sin(doublereal), cos(doublereal), sqrt(
|
||||
doublereal);
|
||||
/* Builtin functions */
|
||||
double asin(doublereal), sin(doublereal), cos(doublereal),
|
||||
sqrt(doublereal);
|
||||
|
||||
/* Local variables */
|
||||
static doublereal dcl1r, dc1rx, dc2rx, drmin, drmax, arg;
|
||||
/* Local variables */
|
||||
static doublereal dcl1r, dc1rx, dc2rx, drmin, drmax, arg;
|
||||
|
||||
/* ----------------------------------------------------------------------- */
|
||||
/* CALCULATE ANGLES ON MONO/ANALYSER */
|
||||
@@ -347,30 +360,30 @@ L999:
|
||||
/* ----------------------------------------------------------------------- */
|
||||
/* 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;
|
||||
}
|
||||
*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.;
|
||||
*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) */
|
||||
@@ -381,39 +394,45 @@ L999:
|
||||
/* RMIN=0. */
|
||||
/* RMAX=20. */
|
||||
/* IN1/IN3/IN12/IN14/IN20 CASE */
|
||||
if (curve_1.inx == 0) {
|
||||
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 {
|
||||
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;
|
||||
}
|
||||
*alx =
|
||||
dcl1r / sin(*ax2 / 57.29577951308232087679815481410517f) *
|
||||
cos(*ax2 / 57.29577951308232087679815481410517f);
|
||||
*rx = dc2rx * sqrt(sin(*ax2 / 57.29577951308232087679815481410517f))
|
||||
- dc1rx;
|
||||
}
|
||||
/* ----------------------------------------------------------------------- */
|
||||
L999:
|
||||
return 0;
|
||||
} /* ex_case__ */
|
||||
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)
|
||||
/* 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;
|
||||
/* System generated locals */
|
||||
doublereal d__1, d__2;
|
||||
|
||||
/* Builtin functions */
|
||||
double acos(doublereal), atan2(doublereal, doublereal), d_sign(doublereal
|
||||
*, doublereal *), d_mod(doublereal *, doublereal *);
|
||||
/* Builtin functions */
|
||||
double acos(doublereal), atan2(doublereal, doublereal), d_sign(doublereal
|
||||
*,
|
||||
doublereal
|
||||
*),
|
||||
d_mod(doublereal *, doublereal *);
|
||||
|
||||
/* Local variables */
|
||||
static doublereal arg, sax3;
|
||||
/* Local variables */
|
||||
static doublereal arg, sax3;
|
||||
|
||||
/* ----------------------------------------------------------------------- */
|
||||
/* DEAL WITH SAMPLE ANGLES CALCULATION FROM Q VERTOR IN C-N PLANE */
|
||||
@@ -438,39 +457,42 @@ L999:
|
||||
/* ----------------------------------------------------------------------- */
|
||||
/* INIT AND TEST */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--qt;
|
||||
/* Parameter adjustments */
|
||||
--qt;
|
||||
|
||||
/* Function Body */
|
||||
*ier = 0;
|
||||
if (abs(*qs) < 1e-6 || abs(*qm) < .001) {
|
||||
*ier = 3;
|
||||
goto L999;
|
||||
}
|
||||
/* 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;
|
||||
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;
|
||||
}
|
||||
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;
|
||||
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.;
|
||||
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 */
|
||||
@@ -479,25 +501,27 @@ L999:
|
||||
/* IF(LPLATE.AND.A3.GT.0.0) AX3=AX3-180 */
|
||||
/* C----------------------------------------------------------------------- */
|
||||
L999:
|
||||
return 0;
|
||||
} /* sam_case__ */
|
||||
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)
|
||||
/* 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;
|
||||
/* System generated locals */
|
||||
real r__1, r__2;
|
||||
|
||||
/* Builtin functions */
|
||||
double cos(doublereal), sin(doublereal), atan2(doublereal, doublereal),
|
||||
sqrt(doublereal);
|
||||
/* 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;
|
||||
/* Local variables */
|
||||
static real hrad, hdir, qpar, hdir2, qperp;
|
||||
static integer ic;
|
||||
static real phi;
|
||||
|
||||
/* ----------------------------------------------------------------------- */
|
||||
/* DEAL WITH HELMOTZ COIL FIELD CALCULATIONS */
|
||||
@@ -508,24 +532,24 @@ L999:
|
||||
/* ----------------------------------------------------------------------- */
|
||||
/* INIT AND TEST */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--c_ih__;
|
||||
--t_ih__;
|
||||
/* 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;
|
||||
/* 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 */
|
||||
@@ -533,37 +557,40 @@ L999:
|
||||
/* 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);
|
||||
qpar = *aki - *akf * cos(*a4 / 57.29577951308232087679815481410517f);
|
||||
qperp = *akf * sin(*a4 / 57.29577951308232087679815481410517f);
|
||||
phi = atan2(qpar, qperp);
|
||||
/* Computing 2nd power */
|
||||
r__1 = *hx;
|
||||
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;
|
||||
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];
|
||||
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__ */
|
||||
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)
|
||||
/* 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 */
|
||||
@@ -573,29 +600,28 @@ L999:
|
||||
/* ----------------------------------------------------------------------- */
|
||||
/* INIT AND TEST */
|
||||
|
||||
/* Parameter adjustments */
|
||||
--t_ih__;
|
||||
/* Parameter adjustments */
|
||||
--t_ih__;
|
||||
|
||||
/* Function Body */
|
||||
*ier = 0;
|
||||
/* 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;
|
||||
}
|
||||
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__ */
|
||||
|
||||
return 0;
|
||||
} /* flip_case__ */
|
||||
|
||||
Reference in New Issue
Block a user