C------------------------------------------------------------------------
C slightly edited version for inclusion into SICS
C
C Mark Koennecke, November 2000
C
C Found that ERRESO looks error messages up in a 2D array. Modified IER
C values to refer to a 1D array.
C
C Mark Koennecke, January 2002 
C-------------------------------------------------------------------------
      SUBROUTINE INICURVE(MIDX, MRX1, MRX2, AIDX, ARX1, ARX2,
     +    MMIN, MMAX, AMIN, AMAX)
C
C Initializes a common with the curvature parameters.
C In: monochrmoator curvatuure motor index and parameters
C 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
      COMMON/CURVE/ICRM,ICRA, ICLM, CM1RX, CM2RX, CA1RX, CA2RX, 
     +  RMMIN, RMMAX, RAMIN, RAMAX, INX, AT_SINQ
      
      ICRM = MIDX
      ICRA = AIDX
      CM1RX = MRX1
      CM2RX = MRX2
      CA1RX = ARX1
      CA2RX = ARX2
      RMMIN = MMIN
      RMMAX = MMAX
      RAMIN = AMIN
      RAMAX = AMAX
      INX = 0
      AT_SINQ = .TRUE.
      ICLM = 0
      RETURN
      END
C-------------------------------------------------------------------------- 
      SUBROUTINE T_CONV (			  ! File [MAD.SRC]T_CONV.FOR
c	=================
     +		      EI,    AKI,    EF,      AKF,    QHKL, EN,
     +		      HX,    HY,     HZ,
     +		      IF1,   IF2,
     +		      LDK,   LDH,    LDF,     LPA,
     +		      DM,    DA,
     +		      HELM,  F1H,    F1V,     F2H,    F2V,  F,
     +		      IFX,   ISS,    ISM,     ISA,
     +		      T_A,   T_RM,   T_ALM,   T_RA,   QM,
     +		      LDRA,  LDR_RM, LDR_ALM, LDR_RA,
     +		      P_IH,  C_IH, A4,
     +		      IER)
c
cdec$	  ident	    'V01D'
C-----------------------------------------------------------------------
C  Other routines in this file:
c
C       SUBROUTINE EX_CASE (DX,ISX,AKX,AX1,AX2,RX,ALX,IER)
C       SUBROUTINE SAM_CASE (QT,QM,QS,AKI,AKF,AX3,AX4,ISS,IER)
C       SUBROUTINE HELM_CASE (HX,HY,HZ,P_IH,AKI,AKF,A4,QM,HELM,IER)
C       SUBROUTINE FLIP_CASE (IF1,IF2,P_IH,F1V,F1H,F2V,F2H,AKI,AKF,IER)
C-----------------------------------------------------------------------
C  INPUTS
C       EI,AKI,EF,AKF,QHKL,EN,HX,HY,HZ : POTENTIAL TARGETS
C	IF1,IF2 Status of flippers On (1) Off (0)
C       LDK(8)          LOGICAL INDICATING IF (ENERGY,K OR Q) ARE DRIVEN
C       LDH,LDF         LOGICAL INDICATING IF (HX,HY,HZ) OR (F1,F2) ARE DRIVEN
C
C     	  configuration of the machine
c
C       LPA             LOGICAL  TRUE IF MACHINE IN POLARIZATION MODE
C       DM,DA,HELM,F1H,F1V,F2H,F2V,F,IFX,ISS,ISM,ISA,QM (F ENERGY UNIT)
C
C  OUTPUTs
C       T_A            TARGETS OF ANGLES A1-A6
C       T_RM,T_ALM     TARGETS OF RM ,LM
C       T_RA	       TARGET  OF RA
C       QM             TARGETS OF QM
C       LDRA           LOGICAL INDICATING WHICH ANGLES ARE TO BE DRIVEN
C       LDR_RM	       LOGICAL INDICATING IF RM  (mono curve)  IS TO BE DRIVEN
C	LDR_ALM	       LOGICAL INDICATING IF ALM (mono transl) IS TO BE DRIVEN
C       LDR_RA	       LOGICAL INDICATING IF RA  (anal curve)  IS TO BE DRIVEN
C       P_IH	       TARGETS OF CURRENTS FOR FLIPPERS AND HELMOTZ (8 CURRENTS)
C       C_IH	       CONVERSION FACTORS FOR HELMOTZ (4 CURRENTS)
C
C  SPECIAL OUTPUTS
C       TARGET OF EI(EF) IS UPDATED IS KI(KF) IS DRIVEN
C       TARGET OF VARIABLE ENERGY IS UPDATED IF EN IS DRIVEN
C-----------------------------------------------------------------------
	implicit      none
c
	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
      COMMON/CURVE/ICRM,ICRA, ICLM, CM1RX, CM2RX, CA1RX, CA2RX, 
     +  RMMIN, RMMAX, RAMIN, RAMAX, INX, AT_SINQ
c
C	include 'curve.inc'
C-----------------------------------------------------------------------
C     			      Define the dummy arguments
c
	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
C-----------------------------------------------------------------------
C        LOCAL VARIABLES
C
	integer*4   i, id, imod, iq
	logical*4   lmoan(2), lqhkle
c
	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
C-----------------------------------------------------------------------
C       SET UP
C       IMOD  INDEX FOR ERROR TREATMENAT BY ERRESO
C       LDQHKLE : LOGICAL INDICATING THAT WE ARE DEALING WITH A MOVE
C       IN RECIPROCICAL SPACE
C       WE REMAP THE ENERGY PB AS FIXED ENERGY IN EDEF(1)
C       AND VARIABLE ENERGY IN EDEF(2)
C       IF ISA IS NUL  SET IFX TO 1 AND PUT EF,KF, EQUAL TO EI,KI
C
        IMOD = 3
	DDM = DM
	DDA = DA
        DO  I = 1,2
          LMOAN(I) = .FALSE.
        ENDDO
        LQHKLE = .FALSE.
        DO IQ = 5,8
          LQHKLE = (LQHKLE .OR. LDK(IQ))
        ENDDO
	DAKI = AKI
	DAKF = AKF
        IF (ISA .EQ. 0) IFX = 1
        EDEF(IFX) = EI
        AKDEF(IFX) = AKI
        EDEF(3-IFX) = EF
        AKDEF(3-IFX) = AKF
        IF( ISA .EQ. 0) THEN
	  EDEF(2) = EDEF(1)
          AKDEF(2) = AKDEF(1)
          LDK(3) = .TRUE.
          LDK(4) = .TRUE.
          T_A(5) = 0.
          T_A(6) = 0.
          LDRA(5) = .TRUE.
          LDRA(6) = .TRUE.
        ENDIF
C-----------------------------------------------------------------------
C       FIRST TAKE IN ACCOUNT THE FIXED ENERGY PB
C
        IF (LDK(2*IFX-1) .OR. LDK(2*IFX)) THEN
          LMOAN(IFX) = .TRUE.
          IF (LDK(2*IFX-1)) THEN
            IER = 1 + 8
            IF(EDEF(1) .LT. EPS1) GOTO 999
            IER = 0
            AKDEF(1) = SQRT(EDEF(1)/F)
          ELSE
            IER = 1 + 8
            IF(AKDEF(1) .LT. EPS1) GOTO 999
            IER = 0
            EDEF(1) = F*AKDEF(1)**2
          ENDIF
        ENDIF
C-----------------------------------------------------------------------
C       NOW TAKE IN ACCOUNT THE VARIABLE ENERGY PB
C       VARIABLE ENERGUY IS DRIVEN EITHER EXPLICITLY
C       E.G. BY DRIVING EI OR KI WITH IFX=2
C        ( AND WE MUST CALCULATE EN FROM EVAR)
C       THE RULE IS : EI=EF+EN : EN IS THE ENERGY LOSS OF NEUTRONS
C       OR ENERGY GAIN OF SAMPLE
C       OR IMPLICITLY  BY DRIVING THE TRANSFERED ENERGY EN
C        ( AND WE MUST CALCULATE EVAR FROM EN)
C       IF KI IS CONSTANT USE THE CURRENT VALUE CONTAINED IN POSN ARRAY
C       TO CALCULATE THE NON-"CONSTANT" K.
C       IF KF IS CONSTANT USE ALWAYS THE VALUE IN TARGET AND
C        DO A DRIVE OF KF TO KEEP A5/A6 IN RIGHT POSITION
C
        IF (LDK(5-2*IFX) .OR. LDK(6-2*IFX)) THEN
          LMOAN(3-IFX) = .TRUE.
          IF (LDK(5-2*IFX)) THEN
            IER = 1 + 8
            IF(EDEF(2) .LT. EPS4) GOTO 999
            IER = 0
            AKDEF(2) = SQRT(EDEF(2)/F)
          ELSE
            IER = 1 + 8
            IF(AKDEF(2) .LT. EPS4) GOTO 999
            IER = 0
            EDEF(2) = F*AKDEF(2)**2
          ENDIF
          EN = (3-2*IFX)*(EDEF(1)-EDEF(2))
        ELSEIF (LQHKLE) THEN
          LMOAN(3-IFX) = .TRUE.
          EDEF(2) = EDEF(1)+(2*IFX-3)*EN
          IER = 1 + 8
          IF(EDEF(2) .LT. EPS4) GOTO 999
          IER = 0
          AKDEF(2) = SQRT(EDEF(2)/F)
        ENDIF
C-----------------------------------------------------------------------
C       CALCULATE MONOCHROMATOR AND ANALYSER ANGLES
C
        IF(LMOAN(1)) THEN
	  DEI = EDEF(IFX)
	  DAKI = AKDEF(IFX)
          CALL EX_CASE(DDM,ISM,DAKI,A1,A2,RM,ALM,0,IER)
          IF (IER .EQ. 0) THEN
	    AKI = DAKI
	    EI = DEI
            T_A(1) = A1
            T_A(2) = A2
            LDRA(1) = .TRUE.
            LDRA(2) = .TRUE.
            if (icrm .ne. 0) then
	      T_RM = RM
	      LDR_RM = .TRUE.
	    endif
            if ((iclm .ne. 0) .and. (inx .ne. 0)) then
      	      T_ALM = ALM
	      LDR_ALM = .TRUE.
	    endif
          ELSE
            IER = IER + 8
            GOTO 999
          ENDIF
        ENDIF
        IF(LMOAN(2)) THEN
	  DEF = EDEF(3-IFX)
	  DAKF = AKDEF(3-IFX)
          CALL EX_CASE(DDA,ISA,DAKF,A5,A6,RA,ALA,1,IER)
          IF (IER .EQ. 0) THEN
            AKF = DAKF
	    EF = DEF
            T_A(5) = A5
            T_A(6) = A6
            LDRA(5) = .TRUE.
            LDRA(6) = .TRUE.
            if (icra .ne. 0) then
	      T_RA = RA
	      LDR_RA = .TRUE.
	    endif
          ELSE
            IER = IER + 8
            GOTO 999
          ENDIF
        ENDIF
C-----------------------------------------------------------------------
C       USE (QH,QK,QL) TO CALCULATE A3 AND A4
C       CALCULATE Q1 AND Q2 IN SCATTERING PLANE
C
        IMOD = 2
        IF (LQHKLE) THEN
	  DO ID = 1,3
	    DQHKL(ID) = QHKL(ID)
	  ENDDO
          CALL RL2SPV(DQHKL,DQT,DQM,DQS,IER)
          IF (IER .NE. 0) GOTO 999
          CALL SAM_CASE(DQT,DQM,DQS,DAKI,DAKF,A3,A4,ISS,IER)
          IF (IER .EQ. 0) THEN
            T_A(3) = A3
            T_A(4) = A4
            LDRA(3) = .TRUE.
            LDRA(4) = .TRUE.
            QM = DQM
          ELSE
            IER = IER + 4
            GOTO 999
          ENDIF
        ENDIF
C-----------------------------------------------------------------------
C        DEAL WITH FLIPPERS AND HELMOTZ COILS IF LPA
C
	IF (LPA) THEN
	  IF (LDF) CALL FLIP_CASE(IF1,IF2,P_IH,F1V,F1H,F2V,F2H,
     +					      AKI,AKF,IER)
	  IF (LDH) CALL HELM_CASE(HX,HY,HZ,P_IH,C_IH,AKI,AKF,
     +					      A4,QM,HELM,IER)
	endif
C-----------------------------------------------------------------------
  999 	CONTINUE
        IF (IER .NE. 0) CALL ERRESO(IMOD,IER)
        RETURN
        END
c
	SUBROUTINE EX_CASE (				    ! Part of T_CONV.FOR
c	==================
     +			     DX,ISX,AKX,AX1,AX2,RX,ALX,MON_OR_ANAL,IER)
C
C     	      CALCULATE  ANGLES ON MONO/ANALYSER
C     	      CALCULATE AX1  AX2
C     	      CALCULATE RX = MONO OR ANAL CURVATURE AND LM = MONO POSIT FOR IN8
C
C  INPUTS
C       DX	      D-SPACINGS
C       ISX	      SENS OF SCATTERING ON CRYSTAL. If =0, this is probably
c			a 3-axis instr. in simulated 2-axis mode and the
c			calculation is for the scattering at the analyser.
c			In this case, we set AX1 = AX2 = 0 which gives a
c			"straight-through" setting of A5 & A6 (because of
c			a simultaneous 90 degree zero offset for A5 -- this
c			is a bit of a hack, if you ask me!).
C       AKX	      TARGET OF MOMENTUM
c	MON_OR_ANAL   =0 if calculation is for mono.
c		      =1 if calculation is for anal.
C  OUTPUTS
C       AX1 AX2	  THETA 2*THETA ANGLES
C       RX	  MONO OR ANALYSER CURVATURE
C       ALX	  SPECIAL TRANSLATION FOR IN8
C       IER
C        1       'KI OR KF CANNOT BE OBTAINED CHECK D-SPACINGS',
C        2       'KI OR KF TOO SMALL',
C        3       'KI OR KF TOO BIG',
C-----------------------------------------------------------------------
        implicit      none
c
	double precision    PI, RD, EPS1
        PARAMETER     (PI = 3.14159265358979323846264338327950D0)
        PARAMETER     (RD = 57.29577951308232087679815481410517D0)
        PARAMETER     (EPS1 = 1.D-1)
C-----------------------------------------------------------------------
C     				  Define the dummy arguments
	double precision    dx
	integer*4	    isx
	double precision    akx, ax1, ax2, rx, alx
	integer*4	    mon_or_anal, ier
C-----------------------------------------------------------------------
C	include 'curve.inc'
C	include 'motdef.inc'
C	include 'iolsddef.inc'
c
      INTEGER ICRM, ICRA, ICLM, INX
      LOGICAL AT_SINQ
      REAL*4 CM1RX, CM2RX, CA1RX, CA2RX, RMMIN, RMMAX
      REAL*4 RAMIN, RAMAX
      COMMON/CURVE/ICRM,ICRA, ICLM, CM1RX, CM2RX, CA1RX, CA2RX, 
     +  RMMIN, RMMAX, RAMIN, RAMAX, INX, AT_SINQ

C	real*4		   tbut(5,NBMOT)
C	equivalence (rbut, tbut)
C-----------------------------------------------------------------------
C     				  LOCAL VAR
c
	double precision    arg, dc1rx, dc2rx, drmin, drmax, dcl1r, my_rx
	integer*4	    ios, indx
C-----------------------------------------------------------------------
C       INIT AND TEST
C
	ier = 0
	ax1 = 0.0
	ax2 = 0.0
	rx  = 0.0
	alx = 0.0
c----------------------------------------------------------------------
c				    Check validity of inputs.
        if (dx .lt. EPS1) ier = 1
        if (akx .lt. EPS1) ier = 2
        arg = PI/(dx * akx)
        if (abs(arg) .gt. 1.0) ier = 3
        if (ier .ne. 0) goto 999
c----------------------------------------------------------------------
	if (mon_or_anal .eq. 0) then	! Use monochr or anal params?
	  indx  = icrm			! Monochr, so set up params.
	  dc1rx = cm1rx
	  dc2rx = cm2rx
	  dcl1r = ICLM
	  drmin = rmmin
	  drmax = rmmax
	else
	  indx  = icra			! Analyser, so set up params.
	  dc1rx = ca1rx			! There is no ALX in this case.
	  dc2rx = ca2rx
	  drmin = ramin
	  drmax = ramax
	endif
c
C	if (indx .ne. 0) then		    ! Include zero-offset in min/max
C	  drmin = drmin + tbut(3,indx)
C	  drmax = drmax + tbut(3,indx)
C	  if (drmin .lt. tbut(1,indx)) drmin = tbut(1,indx)
C	  if (drmax .gt. tbut(2,indx)) drmax = tbut(2,indx)
C	endif
c-----------------------------------------------------------------------
c       Calculation of the two angles
c
	if (isx .eq. 0) then	    ! "Straight-through" mode?
	  ax1 = 0.0		    ! Yes.
	  ax2 = 0.0
	  rx  = drmin
	  alx = 0.0
	  return
	endif
c
        ax1 = asin (arg) * isx * rd
        ax2 = 2.0d0 * ax1
c-----------------------------------------------------------------------
c  Calculation of mono curvature RM or analyser curvature RA
c  Standard law is:
c
c	For monochr: (Vertical)
c	    CM1RX + CM2RX/SIN(abs(A1)/RD)
c
c	For analyser: (Horizontal)
c	    CA1RX + CA2RX*SIN(abs(A5)/RD)
c
c  CM1RX/CM2RX/CA1RX/CA2RX are parameters depending on monochr/analyser and
c  instrument. They are read from CURVE.INI in routine SETUP_MOT_CURVE.
c  e.g.  cm1rx = .47
c        cm2rx = .244
c        rmmin = 0.
c        rmmax = 20.
c-----------------------------------------------------------------------
	if (mon_or_anal .eq. 0) then	    ! Monochr or analyser?
	  if (inx .ne. 0) then		    ! Monochr. Is there a translation?
	    if (iclm .ne. 0) then	    ! Yes, IN8 case. If there's a ..
	      alx = (dcl1r/sin(ax2/rd)) * cos(ax2/rd)	   ! .. motor, do the ..
	      rx  = dc2rx * sqrt(sin(abs(ax2)/rd)) - dc1rx ! .. calculation.
	      rx = dmin1 (dmax1 (rx, drmin), drmax)
	      return
	    endif
	  else					    ! Not IN8 case so, ..
	    my_rx = dc1rx + dc2rx/sin(abs(ax1)/rd)  ! .. simply calculate.
	  endif
	else					    ! Analyser.
	  my_rx = dc1rx + dc2rx * sin(abs(ax1)/rd)  ! Simply calculate.
	endif
c
	if (indx .ne. 0) then	    ! If there's a motor, return the curvature.
	  rx = dmin1 (dmax1 (my_rx, drmin), drmax)
C	  if (rx .ne. my_rx) then
C	    write (iolun, 101, iostat=ios) motnam(indx), my_rx
C  101	    format (' Warning -- ', a8, 'curvature restricted by low ',
C     +		      'or high limits!'/
C     +		    '            Calculated curvature was', f9.2)
C	  endif
	endif
c-----------------------------------------------------------------------
999     continue
        return
        end
c
	SUBROUTINE SAM_CASE (				    ! Part of T_CONV.FOR
c	===================
     +			      QT,QM,QS,AKI,AKF,AX3,AX4,ISS,IER)
C
C               DEAL WITH SAMPLE ANGLES CALCULATION FROM Q VECTOR IN C-N PLANE
C     		CALCULATE A3 AND A4
C  INPUTS
C       QT	  Q-VECTOR IN SCATTERING PLANE
C       QM,QS	  Q MODULUS AND QMODULUS SQUARED
C       AKI,AKF	  MOMEMTA ON MONO AND ANYLSER
C       ISS       SENS OF SCATTERING ON SAMPLE
C
C  OUTPUTS
C       AX3 AX4   ANGLES ON SAMPLES
C       IER	  SAME ERROR AS RL2SPV
C       IER
C        1       'MATRIX S NOT OK',
C        2       'Q NOT IN SCATTERING PLANE',
C        3       'Q MODULUS TOO SMALL',
C        4       'Q MODULUS TOO BIG',
C-----------------------------------------------------------------------
        implicit      none
c
	double precision    RD, EPS3, EPS6
        PARAMETER   (RD = 57.29577951308232087679815481410517D0)
        PARAMETER   (EPS3 = 1.D-3)
	PARAMETER   (EPS6 = 1.D-6)
C-----------------------------------------------------------------------
C     				      Define the dummy arguments
	double precision    qt(3)
	double precision    qm, qs, aki, akf, ax3, ax4
	integer*4	    iss, ier
C-----------------------------------------------------------------------
c					Local variables
	double precision    arg, sax3
C-----------------------------------------------------------------------
C       INIT AND TEST
C
        IER = 0
        IF ((ABS(QS) .LT. EPS6) .OR. (ABS(QM) .LT. EPS3)) THEN
          IER = 3
          GOTO 999
        ENDIF
C-----------------------------------------------------------------------
C       CALCULATE A3 AND MOVE IT INTHE -180 ,+180 INTERVAL
C
        ARG = (AKI**2 + AKF**2 - QS)/(2.D0*AKI*AKF)
        IF(ABS(ARG) .GT. 1.D0)THEN
          IER = 4
          GOTO 999
        ELSE
          AX4 = ACOS(ARG)*ISS*RD
        ENDIF
        AX3 = (-ATAN2(QT(2),QT(1))-ACOS((AKF**2-QS-AKI**2)/
     +				  (-2.D0*QM*AKI))*DSIGN(1.D0,AX4))*RD
        sax3 = Dsign(1.D0,ax3)
        AX3 = DMOD(AX3+sax3*180.D0,360.D0)-sax3*180.D0
C
C       IF(LPLATE) AX3 = -ATAN(SIN(AX4/RD)/(LSA*TAN(AX5/RD)/(ALMS*C
C       1       TAN(AX1/RD))*(AKI/KF)**2-COS(AX4/RD)))*RD       !PLATE FOCALIZATION OPTION
C       IF(AXX3 .GT. 180.D0) AX3 = AX3-360.D0
C       IF( A3 .LT. -180.D0) AX3 = AX3+360.D0
C       IF(LPLATE .AND. (A3 .GT. 0.0)) AX3 = AX3-180
CC-----------------------------------------------------------------------
999     CONTINUE
        RETURN
        END
c
	SUBROUTINE HELM_CASE (				    ! Part of T_CONV.FOR
c	====================
     +			  HX,HY,HZ,T_IH,C_IH,AKI,AKF,A4,QM,HELM,IER)
C
C               DEAL WITH HELMOTZ COIL FIELD CALCULATIONS
C     	        CALCULATE HX HY HZ
C-----------------------------------------------------------------------
c  At ILL:
c	There are 3 coils for Hx/Hy at 120 degrees to each other.
c
c	There is a 4th coil for Hz.
c
c  At SINQ:
c	There is an Hx coil and an Hy coil (actually each is 4 coils powered
c	in series). They are mounted on a ring (SRO). The value of HELM is
c	the angle between the Hx coil and ki.
c
c	There is a 3rd coil for Hz.
C-----------------------------------------------------------------------
        implicit      none
c
C	include 'common_sinq.inc'
c
	double precision    PI, RD, EPS3, EPS4
        PARAMETER     (PI = 3.14159265358979323846264338327950D0)
        PARAMETER     (RD = 57.29577951308232087679815481410517D0)
        PARAMETER     (EPS3 = 1.0D-3)
        PARAMETER     (EPS4 = 1.0D-4)
C-----------------------------------------------------------------------
C     				      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
C-----------------------------------------------------------------------
c					Local variables
	integer*4	 ic, ncoef
	double precision hdir, hdir2, hrad, phi, qpar, qperp
C-----------------------------------------------------------------------
C       INIT AND TEST
C
        AT_SINQ = .TRUE.
	ncoef = 4
	if (at_sinq) ncoef = 3
c
        IER = 1
        IF (ABS(QM) .LT. EPS4) goto 999
	IER = 0
        DO IC = 1,ncoef
          IF (C_IH(IC) .LT. EPS4) IER = 2
        ENDDO
        IF (IER .NE. 0) GOTO 999
C-----------------------------------------------------------------------
C       CALCULATE MODULE AND ANGLES OF IN PLANE FIELD H
C       PHI	      ! Angle between Q and KI (in radians)
C       HRAD	      ! Radial comp. of H
C       HDIR	      ! Direction of H relative to PHI (in radians)
C       HDIR2	      ! Angle between field and axis of Coil 1 (in radians)
C
        qpar  =  aki - akf * cos(a4/RD)
        qperp = -akf * sin(a4/RD)
	if (abs(qpar) .gt. EPS3 .and. abs(qperp) .gt. EPS3) then
	  phi = atan2 (abs(qperp), abs(qpar))
	  if (qpar .gt. 0 .and. qperp .lt. 0) then
	    phi = -phi
	  elseif (qpar .lt. 0 .and. qperp .gt. 0) then
	    phi = PI - phi
	  elseif (qpar .lt. 0 .and. qperp .lt. 0) then
	    phi = phi - PI
	  endif
	elseif (abs(qpar) .gt. EPS3) then
	  if (qpar .ge. 0.0) phi = 0.0
	  if (qpar .lt. 0.0) phi = PI
	elseif (abs(qperp) .gt. EPS3) then
	  if (qperp .ge. 0.0) phi =  0.5 * PI
	  if (qperp .lt. 0.0) phi = -0.5 * PI
	else
	  phi = 0.0
	endif
c
        hrad = sqrt (hx**2 + hy**2)
	if (abs(hx) .gt. EPS3 .and. abs(hy) .gt. EPS3) then
	  hdir = atan2 (abs(hy), abs(hx))
	  if (hx .gt. 0 .and. hy .lt. 0) then
	    hdir = -hdir
	  elseif (hx .lt. 0 .and. hy .gt. 0) then
	    hdir = PI - hdir
	  elseif (hx .lt. 0 .and. hy .lt. 0) then
	    hdir = hdir - PI
	  endif
	elseif (abs(hx) .gt. EPS3) then
	  if (hx .ge. 0.0) hdir = 0.0
	  if (hx .lt. 0.0) hdir = PI
	elseif (abs(hy) .gt. EPS3) then
	  if (hy .ge. 0.0) hdir =  0.5 * PI
	  if (hy .lt. 0.0) hdir = -0.5 * PI
	else
	  hdir = 0.0
	endif
c
	hdir2 = hdir + phi - (helm/RD)
C-----------------------------------------------------------------------
C               !CALC CURRENTS
C               !POSITION OF PSP FOR COIL I
C
	if (.not. at_sinq) then
      	  hdir2 = hdir2 + 0.5 * PI	  ! ???
          do ic = 1,3
	    t_ih(ic+4) = cos(hdir2+(ic-1)*2.*PI/3.)*hrad/c_ih(ic)/1.5
          enddo
          t_ih(8) = hz/c_ih(4)
	else
          t_ih(5) =  cos(hdir2) * hrad/c_ih(1)
          t_ih(6) =  sin(hdir2) * hrad/c_ih(2)
          t_ih(7) =  hz/c_ih(3)
	endif
C-----------------------------------------------------------------------
  999   CONTINUE
        RETURN
        END
c
	SUBROUTINE FLIP_CASE (				    ! Part of T_CONV.FOR
C	====================
     +			  IF1,IF2,T_IH,F1V,F1H,F2V,F2H,AKI,AKF,IER)
C
C               DEAL WITH FLIPPER COIL  CALCULATIONS
C     		CALCULATE P_IF CURRENTS FOR THE TWO FLIPPERS
C-----------------------------------------------------------------------
C     				  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
C-----------------------------------------------------------------------
C       INIT AND TEST
C
        IER = 0
C-----------------------------------------------------------------------
C
        IF (IF1 .EQ. 1) THEN
          T_IH(1) = F1V
          T_IH(2) = AKI*F1H
        ELSE
          T_IH(1) = 0.
          T_IH(2) = 0.
        ENDIF
        IF (IF2 .EQ. 1) THEN
          T_IH(3) = F2V
          T_IH(4) = AKF*F2H
        ELSE
          T_IH(3) = 0.
          T_IH(4) = 0.
        ENDIF
C-----------------------------------------------------------------------
999     CONTINUE
        RETURN
        END
