#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__ */