linse/sics
0
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
c95a7bbd9f3bbba2f4dabedbb935acabfac2abcd
sics/t_conv.c
cvs 1e60f3be82 - Many fixes to the triple axis stuff 
* update after a1-a6 drive
  * intrduction of targets
- POLDI writing
- Moved HKL calculation 4 TRICS to fourlib
2002-01-25 14:48:50 +00:00

1585 lines
45 KiB
C
Raw Blame History

#line 1 "t_conv.f"
/* t_conv.f -- translated by f2c (version 20000817).
You must link the resulting object file with the libraries:
-lf2c -lm (in that order)
*/
#include "f2c.h"
#line 1 "t_conv.f"
/* Common Block Declarations */
struct {
integer icrm, icra, iclm;
real cm1rx, cm2rx, ca1rx, ca2rx, rmmin, rmmax, ramin, ramax;
integer inx;
logical at_sinq__;
} curve_;
#define curve_1 curve_
/* Table of constant values */
static integer c__0 = 0;
static integer c__1 = 1;
static doublereal c_b10 = 1.;
static doublereal c_b12 = 360.;
/* ------------------------------------------------------------------------ */
/* slightly edited version for inclusion into SICS */
/* Mark Koennecke, November 2000 */
/* ------------------------------------------------------------------------- */
/*< >*/
/* Subroutine */ int inicurve_(integer *midx, real *mrx1, real *mrx2, integer
*aidx, real *arx1, real *arx2, real *mmin, real *mmax, real *amin,
real *amax)
{
/* Initializes a common with the curvature parameters. */
/* In: monochrmoator curvatuure motor index and parameters */
/* In: analyzer curvature motor index + parameters */
/*< INTEGER MIDX, AIDX >*/
/*< REAL*4 MRX1, MRX2, ARX1, ARX2, MMIN, MMAX, AMIN, AMAX >*/
/*< REAL*4 CM1RX, CM2RX, CA1RX, CA2RX, RMMIN, RMMAX >*/
/*< REAL*4 RAMIN, RAMAX >*/
/*< INTEGER ICRM, ICRA, ICLM, INX >*/
/*< LOGICAL AT_SINQ >*/
/*< >*/
/*< ICRM = MIDX >*/
#line 21 "t_conv.f"
curve_1.icrm = *midx;
/*< ICRA = AIDX >*/
#line 22 "t_conv.f"
curve_1.icra = *aidx;
/*< CM1RX = MRX1 >*/
#line 23 "t_conv.f"
curve_1.cm1rx = *mrx1;
/*< CM2RX = MRX2 >*/
#line 24 "t_conv.f"
curve_1.cm2rx = *mrx2;
/*< CA1RX = ARX1 >*/
#line 25 "t_conv.f"
curve_1.ca1rx = *arx1;
/*< CA2RX = ARX2 >*/
#line 26 "t_conv.f"
curve_1.ca2rx = *arx2;
/*< RMMIN = MMIN >*/
#line 27 "t_conv.f"
curve_1.rmmin = *mmin;
/*< RMMAX = MMAX >*/
#line 28 "t_conv.f"
curve_1.rmmax = *mmax;
/*< RAMIN = AMIN >*/
#line 29 "t_conv.f"
curve_1.ramin = *amin;
/*< RAMAX = AMAX >*/
#line 30 "t_conv.f"
curve_1.ramax = *amax;
/*< INX = 0 >*/
#line 31 "t_conv.f"
curve_1.inx = 0;
/*< AT_SINQ = .TRUE. >*/
#line 32 "t_conv.f"
curve_1.at_sinq__ = TRUE_;
/*< ICLM = 0 >*/
#line 33 "t_conv.f"
curve_1.iclm = 0;
/*< RETURN >*/
#line 34 "t_conv.f"
return 0;
/*< END >*/
} /* inicurve_ */
/* -------------------------------------------------------------------------- */
/*< >*/
/* 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 *t_ra__, real *qm, logical *
ldra, logical *ldr_rm__, logical *ldr_alm__, logical *ldr_ra__, 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, dqs, dqt[3];
extern /* Subroutine */ int ex_case__(doublereal *, integer *, doublereal
*, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
/* ================= */
/* dec$ ident 'V01D' */
/* ----------------------------------------------------------------------- */
/* Other routines in this file: */
/* 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) */
/* ----------------------------------------------------------------------- */
/* INPUTS */
/* 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) */
/* OUTPUTs */
/* T_A TARGETS OF ANGLES A1-A6 */
/* T_RM,T_ALM TARGETS OF RM ,LM */
/* T_RA TARGET OF RA */
/* QM TARGETS OF QM */
/* LDRA LOGICAL INDICATING WHICH ANGLES ARE TO BE DRIVEN */
/* LDR_RM LOGICAL INDICATING IF RM (mono curve) IS TO BE DRIVEN */
/* LDR_ALM LOGICAL INDICATING IF ALM (mono transl) IS TO BE DRIVEN */
/* LDR_RA LOGICAL INDICATING IF RA (anal curve) IS 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 */
/* ----------------------------------------------------------------------- */
/*< implicit none >*/
/*< REAL*4 EPS1, EPS4 >*/
/*< parameter (EPS1 = 1.D-1) >*/
/*< parameter (EPS4 = 1.D-4) >*/
/*< INTEGER ICRM, ICRA, ICLM, INX >*/
/*< LOGICAL AT_SINQ >*/
/*< REAL*4 CM1RX, CM2RX, CA1RX, CA2RX, RMMIN, RMMAX >*/
/*< REAL*4 RAMIN, RAMAX >*/
/*< >*/
/* include 'curve.inc' */
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/*< real*4 ei, aki, ef, akf, qhkl(3), en >*/
/*< real*4 hx, hy, hz >*/
/*< integer*4 if1, if2 >*/
/*< logical*4 ldk(8), ldh, ldf, lpa >*/
/*< real*4 dm, da >*/
/*< real*4 helm, f1h, f1v, f2h, f2v, f >*/
/*< integer*4 ifx, iss, ism, isa >*/
/*< real*4 t_a(6), t_rm, t_alm, t_ra, qm >*/
/*< logical*4 ldra(6), ldr_rm, ldr_alm, ldr_ra >*/
/*< real*4 p_ih(8), c_ih(4) >*/
/*< integer*4 ier >*/
/* ----------------------------------------------------------------------- */
/* LOCAL VARIABLES */
/*< integer*4 i, id, imod, iq >*/
/*< logical*4 lmoan(2), lqhkle >*/
/*< double precision a1, a2, a3, a4, a5, a6 >*/
/*< double precision ala, alm, dakf, daki, dqm, dqs >*/
/*< double precision def, dei >*/
/*< double precision ra, rm >*/
/*< double precision edef(2), akdef(2), dqhkl(3), dqt(3) >*/
/*< double precision ddm, dda >*/
/* ----------------------------------------------------------------------- */
/* 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 */
/*< IMOD = 3 >*/
#line 135 "t_conv.f"
/* Parameter adjustments */
#line 135 "t_conv.f"
--c_ih__;
#line 135 "t_conv.f"
--p_ih__;
#line 135 "t_conv.f"
--ldra;
#line 135 "t_conv.f"
--t_a__;
#line 135 "t_conv.f"
--ldk;
#line 135 "t_conv.f"
--qhkl;
#line 135 "t_conv.f"
#line 135 "t_conv.f"
/* Function Body */
#line 135 "t_conv.f"
imod = 3;
/*< DDM = DM >*/
#line 136 "t_conv.f"
ddm = *dm;
/*< DDA = DA >*/
#line 137 "t_conv.f"
dda = *da;
/*< DO I = 1,2 >*/
#line 138 "t_conv.f"
for (i__ = 1; i__ <= 2; ++i__) {
/*< LMOAN(I) = .FALSE. >*/
#line 139 "t_conv.f"
lmoan[i__ - 1] = FALSE_;
/*< ENDDO >*/
#line 140 "t_conv.f"
}
/*< LQHKLE = .FALSE. >*/
#line 141 "t_conv.f"
lqhkle = FALSE_;
/*< DO IQ = 5,8 >*/
#line 142 "t_conv.f"
for (iq = 5; iq <= 8; ++iq) {
/*< LQHKLE = (LQHKLE .OR. LDK(IQ)) >*/
#line 143 "t_conv.f"
lqhkle = lqhkle || ldk[iq];
/*< ENDDO >*/
#line 144 "t_conv.f"
}
/*< DAKI = AKI >*/
#line 145 "t_conv.f"
daki = *aki;
/*< DAKF = AKF >*/
#line 146 "t_conv.f"
dakf = *akf;
/*< IF (ISA .EQ. 0) IFX = 1 >*/
#line 147 "t_conv.f"
if (*isa == 0) {
#line 147 "t_conv.f"
*ifx = 1;
#line 147 "t_conv.f"
}
/*< EDEF(IFX) = EI >*/
#line 148 "t_conv.f"
edef[*ifx - 1] = *ei;
/*< AKDEF(IFX) = AKI >*/
#line 149 "t_conv.f"
akdef[*ifx - 1] = *aki;
/*< EDEF(3-IFX) = EF >*/
#line 150 "t_conv.f"
edef[3 - *ifx - 1] = *ef;
/*< AKDEF(3-IFX) = AKF >*/
#line 151 "t_conv.f"
akdef[3 - *ifx - 1] = *akf;
/*< IF( ISA .EQ. 0) THEN >*/
#line 152 "t_conv.f"
if (*isa == 0) {
/*< EDEF(2) = EDEF(1) >*/
#line 153 "t_conv.f"
edef[1] = edef[0];
/*< AKDEF(2) = AKDEF(1) >*/
#line 154 "t_conv.f"
akdef[1] = akdef[0];
/*< LDK(3) = .TRUE. >*/
#line 155 "t_conv.f"
ldk[3] = TRUE_;
/*< LDK(4) = .TRUE. >*/
#line 156 "t_conv.f"
ldk[4] = TRUE_;
/*< T_A(5) = 0. >*/
#line 157 "t_conv.f"
t_a__[5] = 0.f;
/*< T_A(6) = 0. >*/
#line 158 "t_conv.f"
t_a__[6] = 0.f;
/*< LDRA(5) = .TRUE. >*/
#line 159 "t_conv.f"
ldra[5] = TRUE_;
/*< LDRA(6) = .TRUE. >*/
#line 160 "t_conv.f"
ldra[6] = TRUE_;
/*< ENDIF >*/
#line 161 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/* FIRST TAKE IN ACCOUNT THE FIXED ENERGY PB */
/*< IF (LDK(2*IFX-1) .OR. LDK(2*IFX)) THEN >*/
#line 165 "t_conv.f"
if (ldk[(*ifx << 1) - 1] || ldk[*ifx * 2]) {
/*< LMOAN(IFX) = .TRUE. >*/
#line 166 "t_conv.f"
lmoan[*ifx - 1] = TRUE_;
/*< IF (LDK(2*IFX-1)) THEN >*/
#line 167 "t_conv.f"
if (ldk[(*ifx << 1) - 1]) {
/*< IER = 1 + 8 >*/
#line 168 "t_conv.f"
*ier = 9;
/*< IF(EDEF(1) .LT. EPS1) GOTO 999 >*/
#line 169 "t_conv.f"
if (edef[0] < .1f) {
#line 169 "t_conv.f"
goto L999;
#line 169 "t_conv.f"
}
/*< IER = 0 >*/
#line 170 "t_conv.f"
*ier = 0;
/*< AKDEF(1) = SQRT(EDEF(1)/F) >*/
#line 171 "t_conv.f"
akdef[0] = sqrt(edef[0] / *f);
/*< ELSE >*/
#line 172 "t_conv.f"
} else {
/*< IER = 1 + 8 >*/
#line 173 "t_conv.f"
*ier = 9;
/*< IF(AKDEF(1) .LT. EPS1) GOTO 999 >*/
#line 174 "t_conv.f"
if (akdef[0] < .1f) {
#line 174 "t_conv.f"
goto L999;
#line 174 "t_conv.f"
}
/*< IER = 0 >*/
#line 175 "t_conv.f"
*ier = 0;
/*< EDEF(1) = F*AKDEF(1)**2 >*/
/* Computing 2nd power */
#line 176 "t_conv.f"
d__1 = akdef[0];
#line 176 "t_conv.f"
edef[0] = *f * (d__1 * d__1);
/*< ENDIF >*/
#line 177 "t_conv.f"
}
/*< ENDIF >*/
#line 178 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/* 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-2*IFX) .OR. LDK(6-2*IFX)) THEN >*/
#line 193 "t_conv.f"
if (ldk[5 - (*ifx << 1)] || ldk[6 - (*ifx << 1)]) {
/*< LMOAN(3-IFX) = .TRUE. >*/
#line 194 "t_conv.f"
lmoan[3 - *ifx - 1] = TRUE_;
/*< IF (LDK(5-2*IFX)) THEN >*/
#line 195 "t_conv.f"
if (ldk[5 - (*ifx << 1)]) {
/*< IER = 1 + 8 >*/
#line 196 "t_conv.f"
*ier = 9;
/*< IF(EDEF(2) .LT. EPS4) GOTO 999 >*/
#line 197 "t_conv.f"
if (edef[1] < 1e-4f) {
#line 197 "t_conv.f"
goto L999;
#line 197 "t_conv.f"
}
/*< IER = 0 >*/
#line 198 "t_conv.f"
*ier = 0;
/*< AKDEF(2) = SQRT(EDEF(2)/F) >*/
#line 199 "t_conv.f"
akdef[1] = sqrt(edef[1] / *f);
/*< ELSE >*/
#line 200 "t_conv.f"
} else {
/*< IER = 1 + 8 >*/
#line 201 "t_conv.f"
*ier = 9;
/*< IF(AKDEF(2) .LT. EPS4) GOTO 999 >*/
#line 202 "t_conv.f"
if (akdef[1] < 1e-4f) {
#line 202 "t_conv.f"
goto L999;
#line 202 "t_conv.f"
}
/*< IER = 0 >*/
#line 203 "t_conv.f"
*ier = 0;
/*< EDEF(2) = F*AKDEF(2)**2 >*/
/* Computing 2nd power */
#line 204 "t_conv.f"
d__1 = akdef[1];
#line 204 "t_conv.f"
edef[1] = *f * (d__1 * d__1);
/*< ENDIF >*/
#line 205 "t_conv.f"
}
/*< EN = (3-2*IFX)*(EDEF(1)-EDEF(2)) >*/
#line 206 "t_conv.f"
*en = (3 - (*ifx << 1)) * (edef[0] - edef[1]);
/*< ELSEIF (LQHKLE) THEN >*/
#line 207 "t_conv.f"
} else if (lqhkle) {
/*< LMOAN(3-IFX) = .TRUE. >*/
#line 208 "t_conv.f"
lmoan[3 - *ifx - 1] = TRUE_;
/*< EDEF(2) = EDEF(1)+(2*IFX-3)*EN >*/
#line 209 "t_conv.f"
edef[1] = edef[0] + ((*ifx << 1) - 3) * *en;
/*< IER = 1 + 8 >*/
#line 210 "t_conv.f"
*ier = 9;
/*< IF(EDEF(2) .LT. EPS4) GOTO 999 >*/
#line 211 "t_conv.f"
if (edef[1] < 1e-4f) {
#line 211 "t_conv.f"
goto L999;
#line 211 "t_conv.f"
}
/*< IER = 0 >*/
#line 212 "t_conv.f"
*ier = 0;
/*< AKDEF(2) = SQRT(EDEF(2)/F) >*/
#line 213 "t_conv.f"
akdef[1] = sqrt(edef[1] / *f);
/*< ENDIF >*/
#line 214 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/* CALCULATE MONOCHROMATOR AND ANALYSER ANGLES */
/*< IF(LMOAN(1)) THEN >*/
#line 218 "t_conv.f"
if (lmoan[0]) {
/*< DEI = EDEF(IFX) >*/
#line 219 "t_conv.f"
dei = edef[*ifx - 1];
/*< DAKI = AKDEF(IFX) >*/
#line 220 "t_conv.f"
daki = akdef[*ifx - 1];
/*< CALL EX_CASE(DDM,ISM,DAKI,A1,A2,RM,ALM,0,IER) >*/
#line 221 "t_conv.f"
ex_case__(&ddm, ism, &daki, &a1, &a2, &rm, &alm, &c__0, ier);
/*< IF (IER .EQ. 0) THEN >*/
#line 222 "t_conv.f"
if (*ier == 0) {
/*< AKI = DAKI >*/
#line 223 "t_conv.f"
*aki = daki;
/*< EI = DEI >*/
#line 224 "t_conv.f"
*ei = dei;
/*< T_A(1) = A1 >*/
#line 225 "t_conv.f"
t_a__[1] = a1;
/*< T_A(2) = A2 >*/
#line 226 "t_conv.f"
t_a__[2] = a2;
/*< LDRA(1) = .TRUE. >*/
#line 227 "t_conv.f"
ldra[1] = TRUE_;
/*< LDRA(2) = .TRUE. >*/
#line 228 "t_conv.f"
ldra[2] = TRUE_;
/*< if (icrm .ne. 0) then >*/
#line 229 "t_conv.f"
if (curve_1.icrm != 0) {
/*< T_RM = RM >*/
#line 230 "t_conv.f"
*t_rm__ = rm;
/*< LDR_RM = .TRUE. >*/
#line 231 "t_conv.f"
*ldr_rm__ = TRUE_;
/*< endif >*/
#line 232 "t_conv.f"
}
/*< if ((iclm .ne. 0) .and. (inx .ne. 0)) then >*/
#line 233 "t_conv.f"
if (curve_1.iclm != 0 && curve_1.inx != 0) {
/*< T_ALM = ALM >*/
#line 234 "t_conv.f"
*t_alm__ = alm;
/*< LDR_ALM = .TRUE. >*/
#line 235 "t_conv.f"
*ldr_alm__ = TRUE_;
/*< endif >*/
#line 236 "t_conv.f"
}
/*< ELSE >*/
#line 237 "t_conv.f"
} else {
/*< IER = IER + 8 >*/
#line 238 "t_conv.f"
*ier += 8;
/*< GOTO 999 >*/
#line 239 "t_conv.f"
goto L999;
/*< ENDIF >*/
#line 240 "t_conv.f"
}
/*< ENDIF >*/
#line 241 "t_conv.f"
}
/*< IF(LMOAN(2)) THEN >*/
#line 242 "t_conv.f"
if (lmoan[1]) {
/*< DEF = EDEF(3-IFX) >*/
#line 243 "t_conv.f"
def = edef[3 - *ifx - 1];
/*< DAKF = AKDEF(3-IFX) >*/
#line 244 "t_conv.f"
dakf = akdef[3 - *ifx - 1];
/*< CALL EX_CASE(DDA,ISA,DAKF,A5,A6,RA,ALA,1,IER) >*/
#line 245 "t_conv.f"
ex_case__(&dda, isa, &dakf, &a5, &a6, &ra, &ala, &c__1, ier);
/*< IF (IER .EQ. 0) THEN >*/
#line 246 "t_conv.f"
if (*ier == 0) {
/*< AKF = DAKF >*/
#line 247 "t_conv.f"
*akf = dakf;
/*< EF = DEF >*/
#line 248 "t_conv.f"
*ef = def;
/*< T_A(5) = A5 >*/
#line 249 "t_conv.f"
t_a__[5] = a5;
/*< T_A(6) = A6 >*/
#line 250 "t_conv.f"
t_a__[6] = a6;
/*< LDRA(5) = .TRUE. >*/
#line 251 "t_conv.f"
ldra[5] = TRUE_;
/*< LDRA(6) = .TRUE. >*/
#line 252 "t_conv.f"
ldra[6] = TRUE_;
/*< if (icra .ne. 0) then >*/
#line 253 "t_conv.f"
if (curve_1.icra != 0) {
/*< T_RA = RA >*/
#line 254 "t_conv.f"
*t_ra__ = ra;
/*< LDR_RA = .TRUE. >*/
#line 255 "t_conv.f"
*ldr_ra__ = TRUE_;
/*< endif >*/
#line 256 "t_conv.f"
}
/*< ELSE >*/
#line 257 "t_conv.f"
} else {
/*< IER = IER + 8 >*/
#line 258 "t_conv.f"
*ier += 8;
/*< GOTO 999 >*/
#line 259 "t_conv.f"
goto L999;
/*< ENDIF >*/
#line 260 "t_conv.f"
}
/*< ENDIF >*/
#line 261 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/* USE (QH,QK,QL) TO CALCULATE A3 AND A4 */
/* CALCULATE Q1 AND Q2 IN SCATTERING PLANE */
/*< IMOD = 2 >*/
#line 266 "t_conv.f"
imod = 2;
/*< IF (LQHKLE) THEN >*/
#line 267 "t_conv.f"
if (lqhkle) {
/*< DO ID = 1,3 >*/
#line 268 "t_conv.f"
for (id = 1; id <= 3; ++id) {
/*< DQHKL(ID) = QHKL(ID) >*/
#line 269 "t_conv.f"
dqhkl[id - 1] = qhkl[id];
/*< ENDDO >*/
#line 270 "t_conv.f"
}
/*< CALL RL2SPV(DQHKL,DQT,DQM,DQS,IER) >*/
#line 271 "t_conv.f"
rl2spv_(dqhkl, dqt, &dqm, &dqs, ier);
/*< IF (IER .NE. 0) GOTO 999 >*/
#line 272 "t_conv.f"
if (*ier != 0) {
#line 272 "t_conv.f"
goto L999;
#line 272 "t_conv.f"
}
/*< CALL SAM_CASE(DQT,DQM,DQS,DAKI,DAKF,A3,A4,ISS,IER) >*/
#line 273 "t_conv.f"
sam_case__(dqt, &dqm, &dqs, &daki, &dakf, &a3, &a4, iss, ier);
/*< IF (IER .EQ. 0) THEN >*/
#line 274 "t_conv.f"
if (*ier == 0) {
/*< T_A(3) = A3 >*/
#line 275 "t_conv.f"
t_a__[3] = a3;
/*< T_A(4) = A4 >*/
#line 276 "t_conv.f"
t_a__[4] = a4;
/*< LDRA(3) = .TRUE. >*/
#line 277 "t_conv.f"
ldra[3] = TRUE_;
/*< LDRA(4) = .TRUE. >*/
#line 278 "t_conv.f"
ldra[4] = TRUE_;
/*< QM = DQM >*/
#line 279 "t_conv.f"
*qm = dqm;
/*< ELSE >*/
#line 280 "t_conv.f"
} else {
/*< IER = IER + 4 >*/
#line 281 "t_conv.f"
*ier += 4;
/*< GOTO 999 >*/
#line 282 "t_conv.f"
goto L999;
/*< ENDIF >*/
#line 283 "t_conv.f"
}
/*< ENDIF >*/
#line 284 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/* DEAL WITH FLIPPERS AND HELMOTZ COILS IF LPA */
/*< IF (LPA .AND. (LMOAN(1) .OR. LMOAN(2))) THEN >*/
#line 288 "t_conv.f"
if (*lpa && (lmoan[0] || lmoan[1])) {
/*< IF >*/
#line 289 "t_conv.f"
if (*ldf) {
#line 289 "t_conv.f"
flip_case__(if1, if2, &p_ih__[1], f1v, f1h, f2v, f2h, aki, akf,
ier);
#line 289 "t_conv.f"
}
/*< IF >*/
#line 291 "t_conv.f"
if (*ldh) {
#line 291 "t_conv.f"
helm_case__(hx, hy, hz, &p_ih__[1], &c_ih__[1], aki, akf, &a4, qm,
helm, ier);
#line 291 "t_conv.f"
}
/*< endif >*/
#line 293 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/*< 999 CONTINUE >*/
#line 295 "t_conv.f"
L999:
/*< IF (IER .NE. 0) CALL ERRESO(IMOD,IER) >*/
#line 296 "t_conv.f"
if (*ier != 0) {
#line 296 "t_conv.f"
erreso_(&imod, ier);
#line 296 "t_conv.f"
}
/*< RETURN >*/
#line 297 "t_conv.f"
return 0;
/*< END >*/
} /* t_conv__ */
/*< SUBRO >*/
/* Subroutine */ int ex_case__(doublereal *dx, integer *isx, doublereal *akx,
doublereal *ax1, doublereal *ax2, doublereal *rx, doublereal *alx,
integer *mon_or_anal__, integer *ier)
{
/* System generated locals */
doublereal d__1;
/* Builtin functions */
double asin(doublereal), sin(doublereal), cos(doublereal), sqrt(
doublereal);
/* Local variables */
static integer indx;
static doublereal dcl1r, dc1rx, dc2rx, drmin, drmax, my_rx__, arg;
/* ================== */
/* CALCULATE ANGLES ON MONO/ANALYSER */
/* CALCULATE AX1 AX2 */
/* CALCULATE RX = MONO OR ANAL CURVATURE AND LM = MONO POSIT FOR IN8 */
/* INPUTS */
/* DX D-SPACINGS */
/* ISX SENS OF SCATTERING ON CRYSTAL. If =0, this is probably */
/* a 3-axis instr. in simulated 2-axis mode and the */
/* calculation is for the scattering at the analyser. */
/* In this case, we set AX1 = AX2 = 0 which gives a */
/* "straight-through" setting of A5 & A6 (because of */
/* a simultaneous 90 degree zero offset for A5 -- this */
/* is a bit of a hack, if you ask me!). */
/* AKX TARGET OF MOMENTUM */
/* MON_OR_ANAL =0 if calculation is for mono. */
/* =1 if calculation is for anal. */
/* OUTPUTS */
/* 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', */
/* ----------------------------------------------------------------------- */
/*< implicit none >*/
/*< double precision PI, RD, EPS1 >*/
/*< PARAMETER (PI = 3.14159265358979323846264338327950D0) >*/
/*< PARAMETER (RD = 57.29577951308232087679815481410517D0) >*/
/*< PARAMETER (EPS1 = 1.D-1) >*/
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/*< double precision dx >*/
/*< integer*4 isx >*/
/*< double precision akx, ax1, ax2, rx, alx >*/
/*< integer*4 mon_or_anal, ier >*/
/* ----------------------------------------------------------------------- */
/* include 'curve.inc' */
/* include 'motdef.inc' */
/* include 'iolsddef.inc' */
/*< INTEGER ICRM, ICRA, ICLM, INX >*/
/*< LOGICAL AT_SINQ >*/
/*< REAL*4 CM1RX, CM2RX, CA1RX, CA2RX, RMMIN, RMMAX >*/
/*< REAL*4 RAMIN, RAMAX >*/
/*< >*/
/* real*4 tbut(5,NBMOT) */
/* equivalence (rbut, tbut) */
/* ----------------------------------------------------------------------- */
/* LOCAL VAR */
/*< double precision arg, dc1rx, dc2rx, drmin, drmax, dcl1r, my_rx >*/
/*< integer*4 ios, indx >*/
/* ----------------------------------------------------------------------- */
/* INIT AND TEST */
/*< ier = 0 >*/
#line 363 "t_conv.f"
*ier = 0;
/*< ax1 = 0.0 >*/
#line 364 "t_conv.f"
*ax1 = 0.f;
/*< ax2 = 0.0 >*/
#line 365 "t_conv.f"
*ax2 = 0.f;
/*< rx = 0.0 >*/
#line 366 "t_conv.f"
*rx = 0.f;
/*< alx = 0.0 >*/
#line 367 "t_conv.f"
*alx = 0.f;
/* ---------------------------------------------------------------------- */
/* Check validity of inputs. */
/*< if (dx .lt. EPS1) ier = 1 >*/
#line 370 "t_conv.f"
if (*dx < .1) {
#line 370 "t_conv.f"
*ier = 1;
#line 370 "t_conv.f"
}
/*< if (akx .lt. EPS1) ier = 2 >*/
#line 371 "t_conv.f"
if (*akx < .1) {
#line 371 "t_conv.f"
*ier = 2;
#line 371 "t_conv.f"
}
/*< arg = PI/(dx * akx) >*/
#line 372 "t_conv.f"
arg = 3.1415926535897932384626433832795 / (*dx * *akx);
/*< if (abs(arg) .gt. 1.0) ier = 3 >*/
#line 373 "t_conv.f"
if (abs(arg) > 1.f) {
#line 373 "t_conv.f"
*ier = 3;
#line 373 "t_conv.f"
}
/*< if (ier .ne. 0) goto 999 >*/
#line 374 "t_conv.f"
if (*ier != 0) {
#line 374 "t_conv.f"
goto L999;
#line 374 "t_conv.f"
}
/* ---------------------------------------------------------------------- */
/*< if (mon_or_anal .eq. 0) then ! Use monochr or anal params? >*/
#line 376 "t_conv.f"
if (*mon_or_anal__ == 0) {
/*< indx = icrm ! Monochr, so set up params. >*/
#line 377 "t_conv.f"
indx = curve_1.icrm;
/*< dc1rx = cm1rx >*/
#line 378 "t_conv.f"
dc1rx = curve_1.cm1rx;
/*< dc2rx = cm2rx >*/
#line 379 "t_conv.f"
dc2rx = curve_1.cm2rx;
/*< dcl1r = ICLM >*/
#line 380 "t_conv.f"
dcl1r = (doublereal) curve_1.iclm;
/*< drmin = rmmin >*/
#line 381 "t_conv.f"
drmin = curve_1.rmmin;
/*< drmax = rmmax >*/
#line 382 "t_conv.f"
drmax = curve_1.rmmax;
/*< else >*/
#line 383 "t_conv.f"
} else {
/*< indx = icra ! Analyser, so set up params. >*/
#line 384 "t_conv.f"
indx = curve_1.icra;
/*< dc1rx = ca1rx ! There is no ALX in this case. >*/
#line 385 "t_conv.f"
dc1rx = curve_1.ca1rx;
/*< dc2rx = ca2rx >*/
#line 386 "t_conv.f"
dc2rx = curve_1.ca2rx;
/*< drmin = ramin >*/
#line 387 "t_conv.f"
drmin = curve_1.ramin;
/*< drmax = ramax >*/
#line 388 "t_conv.f"
drmax = curve_1.ramax;
/*< endif >*/
#line 389 "t_conv.f"
}
/* if (indx .ne. 0) then ! Include zero-offset in min/max */
/* drmin = drmin + tbut(3,indx) */
/* drmax = drmax + tbut(3,indx) */
/* if (drmin .lt. tbut(1,indx)) drmin = tbut(1,indx) */
/* if (drmax .gt. tbut(2,indx)) drmax = tbut(2,indx) */
/* endif */
/* ----------------------------------------------------------------------- */
/* Calculation of the two angles */
/*< if (isx .eq. 0) then ! "Straight-through" mode? >*/
#line 400 "t_conv.f"
if (*isx == 0) {
/*< ax1 = 0.0 ! Yes. >*/
#line 401 "t_conv.f"
*ax1 = 0.f;
/*< ax2 = 0.0 >*/
#line 402 "t_conv.f"
*ax2 = 0.f;
/*< rx = drmin >*/
#line 403 "t_conv.f"
*rx = drmin;
/*< alx = 0.0 >*/
#line 404 "t_conv.f"
*alx = 0.f;
/*< return >*/
#line 405 "t_conv.f"
return 0;
/*< endif >*/
#line 406 "t_conv.f"
}
/*< ax1 = asin (arg) * isx * rd >*/
#line 408 "t_conv.f"
*ax1 = asin(arg) * *isx * 57.29577951308232087679815481410517;
/*< ax2 = 2.0d0 * ax1 >*/
#line 409 "t_conv.f"
*ax2 = *ax1 * 2.;
/* ----------------------------------------------------------------------- */
/* Calculation of mono curvature RM or analyser curvature RA */
/* Standard law is: */
/* For monochr: */
/* CM1RX + CM2RX/SIN(abs(A1)/RD) */
/* For analyser: */
/* CA1RX + CA2RX*SIN(abs(A5)/RD) */
/* CM1RX/CM2RX/CA1RX/CA2RX are parameters depending on monochr/analyser and */
/* instrument. They are read from CURVE.INI in routine SETUP_MOT_CURVE. */
/* e.g. cm1rx = .47 */
/* cm2rx = .244 */
/* rmmin = 0. */
/* rmmax = 20. */
/* ----------------------------------------------------------------------- */
/*< if (mon_or_anal .eq. 0) then ! Monochr or analyser? >*/
#line 427 "t_conv.f"
if (*mon_or_anal__ == 0) {
/*< if (inx .ne. 0) then ! Monochr. Is there a translation? >*/
#line 428 "t_conv.f"
if (curve_1.inx != 0) {
/*< if (iclm .ne. 0) then ! Yes, IN8 case. If there's a .. >*/
#line 429 "t_conv.f"
if (curve_1.iclm != 0) {
/*< alx = (dcl1r/sin(ax2/rd)) * cos(ax2/rd) ! .. motor, do the .. >*/
#line 430 "t_conv.f"
*alx = dcl1r / sin(*ax2 / 57.29577951308232087679815481410517)
* cos(*ax2 / 57.29577951308232087679815481410517);
/*< rx = dc2rx * sqrt(sin(abs(ax2)/rd)) - dc1rx ! .. calculation. >*/
#line 431 "t_conv.f"
*rx = dc2rx * sqrt(sin(abs(*ax2) /
57.29577951308232087679815481410517)) - dc1rx;
/*< rx = dmin1 (dmax1 (rx, drmin), drmax) >*/
/* Computing MIN */
#line 432 "t_conv.f"
d__1 = max(*rx,drmin);
#line 432 "t_conv.f"
*rx = min(d__1,drmax);
/*< return >*/
#line 433 "t_conv.f"
return 0;
/*< endif >*/
#line 434 "t_conv.f"
}
/*< else ! Not IN8 case so, .. >*/
#line 435 "t_conv.f"
} else {
/*< my_rx = dc1rx + dc2rx/sin(abs(ax1)/rd) ! .. simply calculate. >*/
#line 436 "t_conv.f"
my_rx__ = dc1rx + dc2rx / sin(abs(*ax1) /
57.29577951308232087679815481410517);
/*< endif >*/
#line 437 "t_conv.f"
}
/*< else ! Analyser. >*/
#line 438 "t_conv.f"
} else {
/*< my_rx = dc1rx + dc2rx * sin(abs(ax1)/rd) ! Simply calculate. >*/
#line 439 "t_conv.f"
my_rx__ = dc1rx + dc2rx * sin(abs(*ax1) /
57.29577951308232087679815481410517);
/*< endif >*/
#line 440 "t_conv.f"
}
/*< if (indx .ne. 0) then ! If there's a motor, return the curvature. >*/
#line 442 "t_conv.f"
if (indx != 0) {
/*< rx = dmin1 (dmax1 (my_rx, drmin), drmax) >*/
/* Computing MIN */
#line 443 "t_conv.f"
d__1 = max(my_rx__,drmin);
#line 443 "t_conv.f"
*rx = min(d__1,drmax);
/* if (rx .ne. my_rx) then */
/* write (iolun, 101, iostat=ios) motnam(indx), my_rx */
/* 101 format (' Warning -- ', a8, 'curvature restricted by low ', */
/* + 'or high limits!'/ */
/* + ' Calculated curvature was', f9.2) */
/* endif */
/*< endif >*/
#line 450 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/*< 999 continue >*/
#line 452 "t_conv.f"
L999:
/*< return >*/
#line 453 "t_conv.f"
return 0;
/*< end >*/
} /* ex_case__ */
/*< SUBRO >*/
/* 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 VECTOR IN C-N PLANE */
/* CALCULATE A3 AND A4 */
/* INPUTS */
/* 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 */
/* OUTPUTS */
/* 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', */
/* ----------------------------------------------------------------------- */
/*< implicit none >*/
/*< double precision RD, EPS3, EPS6 >*/
/*< PARAMETER (RD = 57.29577951308232087679815481410517D0) >*/
/*< PARAMETER (EPS3 = 1.D-3) >*/
/*< PARAMETER (EPS6 = 1.D-6) >*/
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/*< double precision qt(3) >*/
/*< double precision qm, qs, aki, akf, ax3, ax4 >*/
/*< integer*4 iss, ier >*/
/* ----------------------------------------------------------------------- */
/* Local variables */
/*< double precision arg, sax3 >*/
/* ----------------------------------------------------------------------- */
/* INIT AND TEST */
/*< IER = 0 >*/
#line 494 "t_conv.f"
/* Parameter adjustments */
#line 494 "t_conv.f"
--qt;
#line 494 "t_conv.f"
#line 494 "t_conv.f"
/* Function Body */
#line 494 "t_conv.f"
*ier = 0;
/*< IF ((ABS(QS) .LT. EPS6) .OR. (ABS(QM) .LT. EPS3)) THEN >*/
#line 495 "t_conv.f"
if (abs(*qs) < 1e-6 || abs(*qm) < .001) {
/*< IER = 3 >*/
#line 496 "t_conv.f"
*ier = 3;
/*< GOTO 999 >*/
#line 497 "t_conv.f"
goto L999;
/*< ENDIF >*/
#line 498 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/* CALCULATE A3 AND MOVE IT INTHE -180 ,+180 INTERVAL */
/*< ARG = (AKI**2 + AKF**2 - QS)/(2.D0*AKI*AKF) >*/
/* Computing 2nd power */
#line 502 "t_conv.f"
d__1 = *aki;
/* Computing 2nd power */
#line 502 "t_conv.f"
d__2 = *akf;
#line 502 "t_conv.f"
arg = (d__1 * d__1 + d__2 * d__2 - *qs) / (*aki * 2. * *akf);
/*< IF(ABS(ARG) .GT. 1.D0)THEN >*/
#line 503 "t_conv.f"
if (abs(arg) > 1.) {
/*< IER = 4 >*/
#line 504 "t_conv.f"
*ier = 4;
/*< GOTO 999 >*/
#line 505 "t_conv.f"
goto L999;
/*< ELSE >*/
#line 506 "t_conv.f"
} else {
/*< AX4 = ACOS(ARG)*ISS*RD >*/
#line 507 "t_conv.f"
*ax4 = acos(arg) * *iss * 57.29577951308232087679815481410517;
/*< ENDIF >*/
#line 508 "t_conv.f"
}
/*< >*/
/* Computing 2nd power */
#line 509 "t_conv.f"
d__1 = *akf;
/* Computing 2nd power */
#line 509 "t_conv.f"
d__2 = *aki;
#line 509 "t_conv.f"
*ax3 = (-atan2(qt[2], qt[1]) - acos((d__1 * d__1 - *qs - d__2 * d__2) / (*
qm * -2. * *aki)) * d_sign(&c_b10, ax4)) *
57.29577951308232087679815481410517;
/*< sax3 = Dsign(1.D0,ax3) >*/
#line 511 "t_conv.f"
sax3 = d_sign(&c_b10, ax3);
/*< AX3 = DMOD(AX3+sax3*180.D0,360.D0)-sax3*180.D0 >*/
#line 512 "t_conv.f"
d__1 = *ax3 + sax3 * 180.;
#line 512 "t_conv.f"
*ax3 = d_mod(&d__1, &c_b12) - 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----------------------------------------------------------------------- */
/*< 999 CONTINUE >*/
#line 520 "t_conv.f"
L999:
/*< RETURN >*/
#line 521 "t_conv.f"
return 0;
/*< END >*/
} /* sam_case__ */
/*< SUBRO >*/
/* 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 */
integer i__1;
real r__1, r__2;
/* Builtin functions */
double cos(doublereal), sin(doublereal), atan2(doublereal, doublereal),
sqrt(doublereal);
/* Local variables */
static doublereal hrad, hdir, qpar, hdir2;
static integer ncoef;
static doublereal qperp;
static integer ic;
static doublereal phi;
static logical at_sinq__;
/* ==================== */
/* DEAL WITH HELMOTZ COIL FIELD CALCULATIONS */
/* CALCULATE HX HY HZ */
/* ----------------------------------------------------------------------- */
/* At ILL: */
/* There are 3 coils for Hx/Hy at 120 degrees to each other. */
/* There is a 4th coil for Hz. */
/* At SINQ: */
/* There is an Hx coil and an Hy coil (actually each is 4 coils powered */
/* in series). They are mounted on a ring (SRO). The value of HELM is */
/* the angle between the Hx coil and ki. */
/* There is a 3rd coil for Hz. */
/* ----------------------------------------------------------------------- */
/*< implicit none >*/
/* include 'common_sinq.inc' */
/*< double precision PI, RD, EPS3, EPS4 >*/
/*< PARAMETER (PI = 3.14159265358979323846264338327950D0) >*/
/*< PARAMETER (RD = 57.29577951308232087679815481410517D0) >*/
/*< PARAMETER (EPS3 = 1.0D-3) >*/
/*< PARAMETER (EPS4 = 1.0D-4) >*/
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/*< real*4 hx, hy, hz >*/
/*< real*4 t_ih(8) >*/
/*< real*4 c_ih(4) >*/
/*< real*4 aki, akf >*/
/*< double precision a4 >*/
/*< real*4 qm, helm >*/
/*< integer*4 ier >*/
/*< LOGICAL AT_SINQ >*/
/* ----------------------------------------------------------------------- */
/* Local variables */
/*< integer*4 ic, ncoef >*/
/*< double precision hdir, hdir2, hrad, phi, qpar, qperp >*/
/* ----------------------------------------------------------------------- */
/* INIT AND TEST */
/*< AT_SINQ = .TRUE. >*/
#line 569 "t_conv.f"
/* Parameter adjustments */
#line 569 "t_conv.f"
--c_ih__;
#line 569 "t_conv.f"
--t_ih__;
#line 569 "t_conv.f"
#line 569 "t_conv.f"
/* Function Body */
#line 569 "t_conv.f"
at_sinq__ = TRUE_;
/*< ncoef = 4 >*/
#line 570 "t_conv.f"
ncoef = 4;
/*< if (at_sinq) ncoef = 3 >*/
#line 571 "t_conv.f"
if (at_sinq__) {
#line 571 "t_conv.f"
ncoef = 3;
#line 571 "t_conv.f"
}
/*< IER = 1 >*/
#line 573 "t_conv.f"
*ier = 1;
/*< IF (ABS(QM) .LT. EPS4) goto 999 >*/
#line 574 "t_conv.f"
if (dabs(*qm) < 1e-4) {
#line 574 "t_conv.f"
goto L999;
#line 574 "t_conv.f"
}
/*< IER = 0 >*/
#line 575 "t_conv.f"
*ier = 0;
/*< DO IC = 1,ncoef >*/
#line 576 "t_conv.f"
i__1 = ncoef;
#line 576 "t_conv.f"
for (ic = 1; ic <= i__1; ++ic) {
/*< IF (C_IH(IC) .LT. EPS4) IER = 2 >*/
#line 577 "t_conv.f"
if (c_ih__[ic] < 1e-4) {
#line 577 "t_conv.f"
*ier = 2;
#line 577 "t_conv.f"
}
/*< ENDDO >*/
#line 578 "t_conv.f"
}
/*< IF (IER .NE. 0) GOTO 999 >*/
#line 579 "t_conv.f"
if (*ier != 0) {
#line 579 "t_conv.f"
goto L999;
#line 579 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/* CALCULATE MODULE AND ANGLES OF IN PLANE FIELD H */
/* PHI ! Angle between Q and KI (in radians) */
/* HRAD ! Radial comp. of H */
/* HDIR ! Direction of H relative to PHI (in radians) */
/* HDIR2 ! Angle between field and axis of Coil 1 (in radians) */
/*< qpar = aki - akf * cos(a4/RD) >*/
#line 587 "t_conv.f"
qpar = *aki - *akf * cos(*a4 / 57.29577951308232087679815481410517);
/*< qperp = -akf * sin(a4/RD) >*/
#line 588 "t_conv.f"
qperp = -(*akf) * sin(*a4 / 57.29577951308232087679815481410517);
/*< if (abs(qpar) .gt. EPS3 .and. abs(qperp) .gt. EPS3) then >*/
#line 589 "t_conv.f"
if (abs(qpar) > .001 && abs(qperp) > .001) {
/*< phi = atan2 (abs(qperp), abs(qpar)) >*/
#line 590 "t_conv.f"
phi = atan2((abs(qperp)), (abs(qpar)));
/*< if (qpar .gt. 0 .and. qperp .lt. 0) then >*/
#line 591 "t_conv.f"
if (qpar > 0. && qperp < 0.) {
/*< phi = -phi >*/
#line 592 "t_conv.f"
phi = -phi;
/*< elseif (qpar .lt. 0 .and. qperp .gt. 0) then >*/
#line 593 "t_conv.f"
} else if (qpar < 0. && qperp > 0.) {
/*< phi = PI - phi >*/
#line 594 "t_conv.f"
phi = 3.1415926535897932384626433832795 - phi;
/*< elseif (qpar .lt. 0 .and. qperp .lt. 0) then >*/
#line 595 "t_conv.f"
} else if (qpar < 0. && qperp < 0.) {
/*< phi = phi - PI >*/
#line 596 "t_conv.f"
phi += -3.1415926535897932384626433832795;
/*< endif >*/
#line 597 "t_conv.f"
}
/*< elseif (abs(qpar) .gt. EPS3) then >*/
#line 598 "t_conv.f"
} else if (abs(qpar) > .001) {
/*< if (qpar .ge. 0.0) phi = 0.0 >*/
#line 599 "t_conv.f"
if (qpar >= 0.f) {
#line 599 "t_conv.f"
phi = 0.f;
#line 599 "t_conv.f"
}
/*< if (qpar .lt. 0.0) phi = PI >*/
#line 600 "t_conv.f"
if (qpar < 0.f) {
#line 600 "t_conv.f"
phi = 3.1415926535897932384626433832795;
#line 600 "t_conv.f"
}
/*< elseif (abs(qperp) .gt. EPS3) then >*/
#line 601 "t_conv.f"
} else if (abs(qperp) > .001) {
/*< if (qperp .ge. 0.0) phi = 0.5 * PI >*/
#line 602 "t_conv.f"
if (qperp >= 0.f) {
#line 602 "t_conv.f"
phi = 1.5707963267948966;
#line 602 "t_conv.f"
}
/*< if (qperp .lt. 0.0) phi = -0.5 * PI >*/
#line 603 "t_conv.f"
if (qperp < 0.f) {
#line 603 "t_conv.f"
phi = -1.5707963267948966;
#line 603 "t_conv.f"
}
/*< else >*/
#line 604 "t_conv.f"
} else {
/*< phi = 0.0 >*/
#line 605 "t_conv.f"
phi = 0.f;
/*< endif >*/
#line 606 "t_conv.f"
}
/*< hrad = sqrt (hx**2 + hy**2) >*/
/* Computing 2nd power */
#line 608 "t_conv.f"
r__1 = *hx;
/* Computing 2nd power */
#line 608 "t_conv.f"
r__2 = *hy;
#line 608 "t_conv.f"
hrad = sqrt(r__1 * r__1 + r__2 * r__2);
/*< if (abs(hx) .gt. EPS3 .and. abs(hy) .gt. EPS3) then >*/
#line 609 "t_conv.f"
if (dabs(*hx) > .001 && dabs(*hy) > .001) {
/*< hdir = atan2 (abs(hy), abs(hx)) >*/
#line 610 "t_conv.f"
hdir = atan2((dabs(*hy)), (dabs(*hx)));
/*< if (hx .gt. 0 .and. hy .lt. 0) then >*/
#line 611 "t_conv.f"
if (*hx > 0.f && *hy < 0.f) {
/*< hdir = -hdir >*/
#line 612 "t_conv.f"
hdir = -hdir;
/*< elseif (hx .lt. 0 .and. hy .gt. 0) then >*/
#line 613 "t_conv.f"
} else if (*hx < 0.f && *hy > 0.f) {
/*< hdir = PI - hdir >*/
#line 614 "t_conv.f"
hdir = 3.1415926535897932384626433832795 - hdir;
/*< elseif (hx .lt. 0 .and. hy .lt. 0) then >*/
#line 615 "t_conv.f"
} else if (*hx < 0.f && *hy < 0.f) {
/*< hdir = hdir - PI >*/
#line 616 "t_conv.f"
hdir += -3.1415926535897932384626433832795;
/*< endif >*/
#line 617 "t_conv.f"
}
/*< elseif (abs(hx) .gt. EPS3) then >*/
#line 618 "t_conv.f"
} else if (dabs(*hx) > .001) {
/*< if (hx .ge. 0.0) hdir = 0.0 >*/
#line 619 "t_conv.f"
if (*hx >= 0.f) {
#line 619 "t_conv.f"
hdir = 0.f;
#line 619 "t_conv.f"
}
/*< if (hx .lt. 0.0) hdir = PI >*/
#line 620 "t_conv.f"
if (*hx < 0.f) {
#line 620 "t_conv.f"
hdir = 3.1415926535897932384626433832795;
#line 620 "t_conv.f"
}
/*< elseif (abs(hy) .gt. EPS3) then >*/
#line 621 "t_conv.f"
} else if (dabs(*hy) > .001) {
/*< if (hy .ge. 0.0) hdir = 0.5 * PI >*/
#line 622 "t_conv.f"
if (*hy >= 0.f) {
#line 622 "t_conv.f"
hdir = 1.5707963267948966;
#line 622 "t_conv.f"
}
/*< if (hy .lt. 0.0) hdir = -0.5 * PI >*/
#line 623 "t_conv.f"
if (*hy < 0.f) {
#line 623 "t_conv.f"
hdir = -1.5707963267948966;
#line 623 "t_conv.f"
}
/*< else >*/
#line 624 "t_conv.f"
} else {
/*< hdir = 0.0 >*/
#line 625 "t_conv.f"
hdir = 0.f;
/*< endif >*/
#line 626 "t_conv.f"
}
/*< hdir2 = hdir + phi - (helm/RD) >*/
#line 628 "t_conv.f"
hdir2 = hdir + phi - *helm / 57.29577951308232087679815481410517;
/* ----------------------------------------------------------------------- */
/* !CALC CURRENTS */
/* !POSITION OF PSP FOR COIL I */
/*< if (.not. at_sinq) then >*/
#line 633 "t_conv.f"
if (! at_sinq__) {
/*< hdir2 = hdir2 + 0.5 * PI ! ??? >*/
#line 634 "t_conv.f"
hdir2 += 1.5707963267948966;
/*< do ic = 1,3 >*/
#line 635 "t_conv.f"
for (ic = 1; ic <= 3; ++ic) {
/*< t_ih(ic+4) = cos(hdir2+(ic-1)*2.*PI/3.)*hrad/c_ih(ic)/1.5 >*/
#line 636 "t_conv.f"
t_ih__[ic + 4] = cos(hdir2 + (ic - 1) * 2.f *
3.1415926535897932384626433832795 / 3.f) * hrad / c_ih__[
ic] / 1.5f;
/*< enddo >*/
#line 637 "t_conv.f"
}
/*< t_ih(8) = hz/c_ih(4) >*/
#line 638 "t_conv.f"
t_ih__[8] = *hz / c_ih__[4];
/*< else >*/
#line 639 "t_conv.f"
} else {
/*< t_ih(5) = cos(hdir2) * hrad/c_ih(1) >*/
#line 640 "t_conv.f"
t_ih__[5] = cos(hdir2) * hrad / c_ih__[1];
/*< t_ih(6) = sin(hdir2) * hrad/c_ih(2) >*/
#line 641 "t_conv.f"
t_ih__[6] = sin(hdir2) * hrad / c_ih__[2];
/*< t_ih(7) = hz/c_ih(3) >*/
#line 642 "t_conv.f"
t_ih__[7] = *hz / c_ih__[3];
/*< endif >*/
#line 643 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/*< 999 CONTINUE >*/
#line 645 "t_conv.f"
L999:
/*< RETURN >*/
#line 646 "t_conv.f"
return 0;
/*< END >*/
} /* helm_case__ */
/*< SUBRO >*/
/* 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 */
/* ----------------------------------------------------------------------- */
/* Define the dummy arguments */
/*< integer*4 if1, if2 >*/
/*< real*4 t_ih(8) >*/
/*< real*4 f1v, f1h, f2v, f2h >*/
/*< real*4 aki, akf >*/
/*< integer*4 ier >*/
/* ----------------------------------------------------------------------- */
/* INIT AND TEST */
/*< IER = 0 >*/
#line 665 "t_conv.f"
/* Parameter adjustments */
#line 665 "t_conv.f"
--t_ih__;
#line 665 "t_conv.f"
#line 665 "t_conv.f"
/* Function Body */
#line 665 "t_conv.f"
*ier = 0;
/* ----------------------------------------------------------------------- */
/*< IF (IF1 .EQ. 1) THEN >*/
#line 668 "t_conv.f"
if (*if1 == 1) {
/*< T_IH(1) = F1V >*/
#line 669 "t_conv.f"
t_ih__[1] = *f1v;
/*< T_IH(2) = AKI*F1H >*/
#line 670 "t_conv.f"
t_ih__[2] = *aki * *f1h;
/*< ELSE >*/
#line 671 "t_conv.f"
} else {
/*< T_IH(1) = 0. >*/
#line 672 "t_conv.f"
t_ih__[1] = 0.f;
/*< T_IH(2) = 0. >*/
#line 673 "t_conv.f"
t_ih__[2] = 0.f;
/*< ENDIF >*/
#line 674 "t_conv.f"
}
/*< IF (IF2 .EQ. 1) THEN >*/
#line 675 "t_conv.f"
if (*if2 == 1) {
/*< T_IH(3) = F2V >*/
#line 676 "t_conv.f"
t_ih__[3] = *f2v;
/*< T_IH(4) = AKF*F2H >*/
#line 677 "t_conv.f"
t_ih__[4] = *akf * *f2h;
/*< ELSE >*/
#line 678 "t_conv.f"
} else {
/*< T_IH(3) = 0. >*/
#line 679 "t_conv.f"
t_ih__[3] = 0.f;
/*< T_IH(4) = 0. >*/
#line 680 "t_conv.f"
t_ih__[4] = 0.f;
/*< ENDIF >*/
#line 681 "t_conv.f"
}
/* ----------------------------------------------------------------------- */
/*< 999 CONTINUE >*/
#line 683 "t_conv.f"
/* L999: */
/*< RETURN >*/
#line 684 "t_conv.f"
return 0;
/*< END >*/
} /* flip_case__ */
Reference in New Issue View Git Blame Copy Permalink