      PROGRAM K0TEST
C--------------------------------------------------------------------
C  FORTRAN 77 program to test BESK0
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following three
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MAXEXP - the smallest positive power of BETA
C                          that overflows
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 XMIN   - the smallest non-vanishing normalized
C                          floating-point power of the radix, i.e.,
C                          XMIN = FLOAT(IBETA) ** MINEXP
C                 XMAX   - the largest finite floating-point number.
C                          In particular XMAX = (1.0-EPSNEG) *
C                          FLOAT(IBETA) ** MAXEXP
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  User defined functions
C
C         BOT, TOP
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 14, 1992
C
C  Author: Laura Stoltz
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C-----------------------------------------------------------------
      LOGICAL SFLAG,TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MB,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
      DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,AMAXEXP,ATETEN,B,BESEK0,BESK0,BESK1,BETA,
     2   BOT,C,CONST,CONV,DEL,EIGHT,EPS,EPSNEG,FIVE,HALF,ONE,ONENEG,
     3   ONE28,PI,REN,R6,R7,SUM,T,TOP,TWENTY,TWO,U,W,X,XA,XB,XDEN,
     4   XL,XLAM,XLARGE,XMAX,XMB,XMIN,XN,XNINE,X1,Y,Z,ZERO,ZZ
      DIMENSION U(0:559)
CS    DATA ZERO,HALF,ONE,TWO,EIGHT/0.0E0,0.5E0,1.0E0,2.0E0,8.0E0/,
CS   1   XNINE,ATETEN,TWENTY,ONE28/9.0E0,18.0E0,20.0E0,128.0E0/,
CS   2   FIVE,ONENEG,XDEN,ALL9/5.0E0,-1.0E0,16.0E0,-999.0E0/,
CS   3   PI/3.141592653589793E0/
      DATA ZERO,HALF,ONE,TWO,EIGHT/0.0D0,0.5D0,1.0D0,2.0D0,8.0D0/,
     1   XNINE,ATETEN,TWENTY,ONE28/9.0D0,18.0D0,20.0D0,128.0D0/,
     2   FIVE,ONENEG,XDEN,ALL9/5.0D0,-1.0D0,16.0D0,-999.0D0/,
     3   PI/3.141592653589793D0/
      DATA IOUT/6/
      TOP(X) = -X - HALF*LOG(TWO*X) + LOG(ONE-(ONE/EIGHT-XNINE/
     1   ONE28/X)/X)
      BOT(X) = (XDEN*X-ATETEN) / (((ONE28*X-XDEN)*X+XNINE)*X)
     1   - ONE - HALF/X
C------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
      CONV(NDUM) = DBLE(NDUM)
C-----------------------------------------------------------------
C  Determine machine parameters and set constants
C-----------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      AMAXEXP = CONV(MAXEXP)
      JT = 0
      B = EPS
      XLAM = (XDEN - ONE) / XDEN
      CONST = HALF * LOG(PI) - LOG(XMIN)
C-----------------------------------------------------------------
C     Random argument accuracy tests
C-----------------------------------------------------------------
      DO 300 J = 1, 3
         SFLAG = ((J .EQ. 1) .AND. (AMAXEXP/AIT .LE. FIVE))
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         N = 2000
         IF (SFLAG) B = SQRT(EPS)
         A = B
         IF (J .EQ. 1) THEN
               B = ONE
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
            ELSE
               B = TWENTY
         END IF
         XN = CONV(N)
         DEL = (B - A) / XN
         XL = A
C------------------------------------------------------------------
C   Accuracy test is based on the multiplication theorem
C------------------------------------------------------------------
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
            Y = X / XLAM
            W = XDEN * Y
            Y = (W + Y) - W
            X = Y * XLAM
            U(0) = BESK0(Y)
            U(1) = BESK1(Y)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
                  U(0) = U(0) * EPS
                  U(1) = U(1) * EPS
            END IF
            MB = 1
            XMB = ONE
            Y = Y * HALF
            T = U(0) * EPS
            W = (ONE-XLAM) * (ONE+XLAM)
            C = W *Y
            DO 110 II = 2, 60
               T = XMB * T / C
               Z = U(II-1)
               IF (Z .LT. T) THEN
                     GO TO 120
                  ELSE IF (U(II-1) .GT. ONE) THEN
                     IF ((XMB/Y) .GT. (XMAX/U(II-1))) THEN
                           XL = XL + DEL
                           A = XL
                           GO TO  200
                     END IF
               END IF
               U(II) = XMB/Y * U(II-1) + U(II-2)
               XMB = XMB + ONE
               MB = MB + 1
  110       CONTINUE
  120       SUM = U(MB)
            IND = MB
            DO 155 II = 1, MB
               IND = IND - 1
               SUM = SUM * W * Y / XMB + U(IND)
               XMB = XMB - ONE
  155       CONTINUE
            ZZ = SUM
            IF (TFLAG) ZZ = ZZ / EPS
            Z = BESK0(X)
            Y = Z
            IF (U(0) .GT. Y) Y= U(0)
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
                  R6 = W
                  X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
         N = K1 + K2 + K3
         XN = CONV(N)
         R7 = SQRT(R7/XN)
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = ALL9
         IF (R6 .NE. ZERO) W = LOG(R6)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = ALL9
         IF (R7 .NE. ZERO) W = LOG(R7)/ALBETA
         IF (J .EQ. 3) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
  300 CONTINUE
C-----------------------------------------------------------------
C  Special tests
C-----------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031)
      Y = BESK0(XMIN)
      WRITE (IOUT,1032) Y
      Y = BESK0(ZERO)
      WRITE (IOUT,1033) 0,Y
      X = REN(JT) * ONENEG
      Y = BESK0(X)
      WRITE (IOUT,1034) X,Y
      Y = BESEK0(XMAX)
      WRITE (IOUT,1035) Y
      XA = LOG(XMAX)
  330 XB = XA - (TOP(XA)+CONST) / BOT(XA)
      IF (ABS(XB-XA)/XB .LE. EPS) THEN
            GO TO 350
         ELSE
            XA = XB
            GO TO 330
      END IF
  350 XLARGE = XB * XLAM
      Y = BESK0(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      XLARGE = XB * (XNINE / EIGHT)
      Y = BESK0(XLARGE)
      WRITE (IOUT,1034) XLARGE,Y
      STOP
C-----------------------------------------------------------------
 1000 FORMAT('1Test of K0(X) vs Multiplication Theorem'//)
 1010 FORMAT(I7,' random arguments were tested from the interval (',
     1    F5.1,',',F5.1,')'//)
 1011 FORMAT(' ABS(K0(X)) was larger',I6,' times,'/
     1    20X,' agreed',I6,' times, and'/
     1    16X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.'//)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1    ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4E3,' = ',I4,' **',
     1    F7.2/4X,'occurred for X =',E13.6E3)
 1025 FORMAT(' The root mean square absolute error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(//' Test with extreme arguments'/)
 1032 FORMAT(' K0(XMIN) = ',E24.17E3/)
 1033 FORMAT(' K0(',I1,') = ',E24.17E3/)
 1034 FORMAT(' K0(',E24.17E3,' ) = ',E24.17E3/)
 1035 FORMAT(' E**X * K0(XMAX) = ',E24.17E3/)
C     ---------- Last line of BESK0 test program ----------
      END


        subroutine calculsi(nbnn,co3d,poro,ip,npgau,
     1   xgau,frgau,dfrgau,poigau,detj,cnorme, si)
        implicit none
        integer nbnn,ip,npgau,l,idimg,dimch
        real*8 co3d(8,3),poro(1),xgau(npgau,3),cnorme(3)
        real*8 FRGAU(NPGAU,NBNN),DFRGAU(NPGAU,NBNN,3)
        real*8 POIGAU(NPGAU)
        real*8 DETJ(NPGAU)
        real*8 valem(1),si(nbnn)
        real*8 AJM1(27,3,3),AJ(27,3,3),DF(27,4,3),xl(8,3)

        logical JSHORT,LCHAMP
        JSHORT = .TRUE.
        if (nbnn.ne.4) stop 'erreur calculsi'
        l=1
        idimg=2
        valem(1)=1
        call TRCO32(CO3D,Cnorme,nbnn,xl)
        CALL JACOB(IDIMG ,NBNN ,NPGAU ,XL     ,XGAU
     1            ,DETJ  ,AJM1 ,AJ     ,JSHORT)
        LCHAMP= (ip.eq.1)
        dimch=1
        CALL LNFIXX(VALEM , FRGAU  , DETJ   ,
     1     POIGAU , NBNN , NPGAU ,
     1                dimch, LCHAMP , poro , si)
90    CONTINUE
C
      RETURN
      END


      SUBROUTINE RHS(YY,YP)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!    01/09/14, K.Travis
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      USE header_file
      IMPLICIT NONE

      INTEGER :: I, J, IP
      REAL(kind = double) :: XI,XJ,ZJ,YI,YJ,ZI,XIJ,YIJ,ZIJ
      REAL(kind = double) :: R, RSQ, FACTOR, FORCE_MN,DELR
      REAL(kind = double) :: RATIO, FORCE_REP,SUMPXPY,TFLAG
      REAL(kind = double) :: RRR,RR6,RR12,FORCEIJ,PXYP,PXYK,PXYV
      REAL(kind = double) :: RDIF,RDIF2,RDIF3,RXX,RYY,RZZ,RAI,RBI,RCI,RAJ,RBJ,RCJ
      REAL(kind = double) :: ESUM,TK,SUMFP,SUMPP,SUMZFX

      REAL(kind = double), DIMENSION(NEQ) ::  YY,YP
      REAL(kind = double), DIMENSION(N)   ::  FX,FY,FZ

      FX = (/ (I*0.0D0,I = 1,N) /)
      FY = (/ (I*0.0D0,I = 1,N) /)
      FZ = (/ (I*0.0D0,I = 1,N) /)

!     store arguments into local arrays

      DO I = 1,N
        X(I)    = YY(I)
        Y(I)    = YY(I+N)
        Z(I)    = YY(I+N+N)
        PX(I)   = YY(I+N+N+N)
        PY(I)   = YY(I+N+N+N+N)
        PZ(I)   = YY(I+N+N+N+N+N)
      END DO
      ZETA      = YY(N+N+N+N+N+N+1)

!     compute the instantaneous temperature

      ESUM = 0.0D0
      DO I = 1,N
          ESUM = ESUM + PX(I)**2/MASS(I) + PY(I)**2/MASS(I) + PZ(I)**2/MASS(I)
      END DO

      TK = ESUM/DEGFREE

! calculate pair forces
      DO IP = 1, NPAIRS
        I = NI(IP)
        J = NJ(IP)
        XI = X(I)
        YI = Y(I)
        ZI = Z(I)
        CALL CARTFRAC(XI,YI,ZI,RAI,RBI,RCI)
        XJ = X(J)
        YJ = Y(J)
        ZJ = Z(J)
        CALL CARTFRAC(XJ,YJ,ZJ,RAJ,RBJ,RCJ)
        RAJ = RAJ - ANINT(RAJ-RAI)
        RBJ = RBJ - ANINT(RBJ-RBI)
        RCJ = RCJ - ANINT(RCJ-RCI)
        CALL FRACCART(RAJ,RBJ,RCJ,XJ,YJ,ZJ)
        XIJ = XI - XJ
        YIJ = YI - YJ
        ZIJ = ZI - ZJ
        RSQ = XIJ*XIJ + YIJ*YIJ + ZIJ*ZIJ
        IF(RSQ < CUTSQ) THEN

          CALL PAIR_FORCE(RSQ,FORCEIJ)
          FX(I) = FX(I) + FORCEIJ*XIJ
          FY(I) = FY(I) + FORCEIJ*YIJ
          FZ(I) = FZ(I) + FORCEIJ*ZIJ
          FX(J) = FX(J) - FORCEIJ*XIJ
          FY(J) = FY(J) - FORCEIJ*YIJ
          FZ(J) = FZ(J) - FORCEIJ*ZIJ
       END IF

      END DO

      IF(ITHERM.EQ.1) THEN
        TFLAG = 1.0D0
      ELSE
        TFLAG = 0.0D0
      END IF

 !!! pack all first derivatives into a 1-D array

      DO I = 1, N
          YP(I)                  = PX(I)/MASS(I) + SHEAR*Y(I)
          YP(I+N)                = PY(I)/MASS(I)
          YP(I+N+N)              = PZ(I)/MASS(I)
          YP(I+N+N+N)            = FX(I) - ZETA*PX(I) - SHEAR*PY(I)
          YP(I+N+N+N+N)          = FY(I) - ZETA*PY(I)
          YP(I+N+N+N+N+N)        = FZ(I) - ZETA*PZ(I)
      END DO
      YP(N+N+N+N+N+N+1)          = TFLAG*(TK - TREQ)/(TAU_TEMP_SQD*TREQ)

      END SUBROUTINE


module ideq

  implicit none

  private

  public :: B_psi
  public :: dfit_init, idfitin, gradient, eqitem, bgradient, dfit_finish

  public :: invR
  public :: Rpos
  public :: Zpos
  public :: btori,    initialize_btori
  public :: dbtori,   initialize_dbtori
  public :: qfun,     initialize_q
  public :: pfun,     initialize_pressure
  public :: dpfun,    initialize_dpressure
  public :: betafun,  initialize_beta
  public :: psi,      initialize_psi
  public :: diameter, initialize_diameter
  public :: rcenter,  initialize_rcenter

  integer :: nr, nt

  real, allocatable, dimension (:) :: rho_d, eqpsi, psi_bar, fp, qsf, beta, pressure, diam, rc
  real, allocatable, dimension (:) :: rho_mid, psi_mid
  real, allocatable, dimension (:,:)   :: R_psi, Z_psi, B_psi
  real, allocatable, dimension (:,:,:) :: dpm, dtm, drm, dzm, dbm, dbtm
  real, allocatable, dimension (:,:,:) :: dpcart, dbcart, dtcart, dbtcart
  real, allocatable, dimension (:,:,:) :: dpbish, dbbish, dtbish, dbtbish

  real :: psi_N, psi_a, psi_0
  real :: R_mag, Z_mag, B_T0, aminor, beta_0

  logical :: init_btori = .true.
  logical :: init_dbtori = .true.
  logical :: init_q = .true.
  logical :: init_pressure = .true.
  logical :: init_dpressure = .true.
  logical :: init_beta = .true.
  logical :: init_rho = .true.
  logical :: init_psi = .true.
  logical :: init_R = .true.
  logical :: init_Z = .true.
  logical :: init_invR = .true.
  logical :: init_rcenter = .true.
  logical :: init_diameter = .true.

contains
  subroutine idfitin(eqfile, theta, psi_0_out, psi_a_out, rmaj, B_T, amin, initeq)
    use constants, only: twopi
    use splines, only: new_periodic_spline, delete_periodic_spline, periodic_splint, periodic_spline
    implicit none

    type :: grid_type
       integer :: nt
       real, dimension (:), pointer :: R => null ()
       real, dimension (:), pointer :: Z => null ()
       real, dimension (:), pointer :: B => null ()
       real, dimension (:), pointer :: theta => null ()
       type (periodic_spline) :: spl
    end type grid_type

    type :: eq_type
       integer :: nr
       real, dimension (:), pointer :: pbar => null ()
       real, dimension (:), pointer :: psi => null ()
       real, dimension (:), pointer :: pressure => null ()
       real, dimension (:), pointer :: volume => null ()
       type (grid_type), dimension (:), pointer :: grid => null ()
    end type eq_type

    type (eq_type) :: d

    character(80), intent (in) :: eqfile
    real, dimension(:), intent (in) :: theta
    real, intent (out) :: rmaj, amin, psi_a_out, psi_0_out, B_T
    integer, intent (in) :: initeq

    real :: xdum
    real :: I_ring
    real :: dpsidr, dpsidz

    integer :: i, j, init
    integer :: idum, jj, nthg
    integer :: jmax

    character(80) :: filename
    character (200) :: line
!What is this for?
    data init /1/
    save init

! Need to generalize initialization condition if equilibrium changes

    if(initeq == 0) return
    init=0

    nt = size(theta)
    i=index(eqfile,' ')-1
    filename = eqfile(1:i)
    open(unit=5,file=filename,status='old',form='formatted')

! Read the data

    read (5, fmt="(a)") line
    read (5, fmt="(a)") line
    read (5,*) R_mag, Z_mag, I_ring
    read (5, fmt="(a)") line
    read (5, *) d%nr
    read (5, fmt="(a)") line
    read (5, fmt="(a)") line

    allocate (d%pbar     (d%nr))
    allocate (d%psi      (d%nr))
    allocate (d%pressure (d%nr))
    allocate (d%volume   (d%nr))
    allocate (d%grid     (d%nr))

    do i=1,d%nr
       read(5,*) idum, d%pbar(i), d%psi(i), d%pressure(i), xdum, d%volume(i), d%grid(i)%nt
       d%grid(i)%nt = d%grid(i)%nt-1
       jmax = d%grid(i)%nt
       allocate (d%grid(i)%R     (jmax))
       allocate (d%grid(i)%Z     (jmax))
       allocate (d%grid(i)%B     (jmax))
       allocate (d%grid(i)%theta (jmax))
       do j=1,jmax
          read (5,*) d%grid(i)%R(j), d%grid(i)%Z(j), dpsidR, dpsidZ
! make B:
          d%grid(i)%B(j) = sqrt(dpsidR**2 + dpsidZ**2)/(d%grid(i)%R(j)*twopi)
          d%grid(i)%theta(j) = atan2 (d%grid(i)%Z(j) - Z_mag, (d%grid(i)%R(j) - R_mag))
       end do
       read (5,*) xdum, xdum, xdum, xdum
    end do

! different from tokamak case
! here, psi_0 is the value of psi on the innermost flux surface that is kept in equilibrium
! and psi_a is the last flux surface kept.
    psi_0 = d%psi(1)
    psi_a = d%psi(d%nr)

    do i=1,d%nr
       call sort (d%grid(i)%theta, d%grid(i)%R, d%grid(i)%Z, d%grid(i)%B)
    end do

! Spline the data onto a regular grid for later use.

!     R_psi(1:nr, 1:nt)
!     Z_psi(1:nr, 1:nt)
!     B_psi(1:nr, 1:nt)
!
! nt determined from input file by user

!!! need to define our theta grid.  still not right

    call alloc_arrays (d%nr, nt)

    do i = 1, d%nr
       call new_periodic_spline (d%grid(i)%nt, d%grid(i)%theta(:), d%grid(i)%R(:), twopi, d%grid(i)%spl)
       do jj = 1, nt
          R_psi (i, jj) = periodic_splint (theta(jj), d%grid(i)%spl)
       end do
       call delete_periodic_spline (d%grid(i)%spl)
    end do

    do i = 1, d%nr
       call new_periodic_spline (d%grid(i)%nt, d%grid(i)%theta(:), d%grid(i)%Z(:), twopi, d%grid(i)%spl)
       do jj = 1, nt
          Z_psi (i, jj) = periodic_splint (theta(jj), d%grid(i)%spl)
       end do
       call delete_periodic_spline (d%grid(i)%spl)
    end do

    do i = 1, d%nr
       call new_periodic_spline (d%grid(i)%nt, d%grid(i)%theta(:), d%grid(i)%B(:), twopi, d%grid(i)%spl)
       do jj = 1, nt
          B_psi (i, jj) = periodic_splint (theta(jj), d%grid(i)%spl)
       end do
       call delete_periodic_spline (d%grid(i)%spl)
    end do

    qsf = 0.
    rmaj = 1.
! B at center of ring is mu_0 I / (2 a)
    B_T0 = 4.*3.1415*1.e-7*I_ring*0.5/R_mag

    write(*,*) 'B_T0 = ',B_T0
    B_T = B_T0

    psi_N = B_T0 * R_mag**2
    psi_a_out = psi_a / psi_N
    psi_0_out = psi_0 / psi_N

    R_psi = R_psi/R_mag
    Z_psi = Z_psi/R_mag
    B_psi = B_psi/B_T0

    eqpsi = d%psi / psi_N

    fp = 0.
    nthg = nt

!!! need to define the rho_d grid

    rho_d = 1.-R_psi(:,1)

! recover some memory:

    do i = 1, d%nr
       deallocate (d%grid(i)%R)
       deallocate (d%grid(i)%Z)
       deallocate (d%grid(i)%B)
       deallocate (d%grid(i)%theta)
    end do
    deallocate (d%grid)
  end subroutine idfitin

  subroutine alloc_arrays(nr, nt)
    integer, intent(in) :: nr, nt

    if(.not.allocated(rho_d)) then
       allocate(rho_d(nr), eqpsi(nr), psi_bar(nr), fp(nr), qsf(nr), beta(nr), pressure(nr), &
            rc(nr), diam(nr))
       allocate(R_psi(nr, nt), Z_psi(nr, nt), B_psi(nr, nt))
       allocate(drm(nr, nt, 2), dzm(nr, nt, 2), dbm(nr, nt, 2), dbtm(nr, nt, 2), &
            dpm(nr, nt, 2), dtm(nr, nt, 2))
       allocate(dpcart(nr, nt, 2), dbcart(nr, nt, 2), dtcart(nr, nt, 2), dbtcart(nr, nt, 2))
       allocate(dpbish(nr, nt, 2), dbbish(nr, nt, 2), dtbish(nr, nt, 2), dbtbish(nr, nt, 2))
    endif
  end subroutine alloc_arrays

  subroutine dealloc_arrays
    implicit none
    if(allocated(rho_d)) deallocate(rho_d,eqpsi,psi_bar,fp,qsf,beta,pressure,rc,diam)
    if(allocated(R_psi)) deallocate(R_psi,Z_psi,B_psi)
    if(allocated(drm)) deallocate(drm,dzm,dbm,dbtm,dpm,dtm)
    if(allocated(dpcart)) deallocate(dpcart,dbcart,dtcart,dbtcart)
    if(allocated(dpbish)) deallocate(dpbish,dbbish,dtbish,dbtbish)
  end subroutine dealloc_arrays

  subroutine dfit_finish
    implicit none
    call dealloc_arrays
  end subroutine dfit_finish

  subroutine dfit_init
    use constants, only: pi
    implicit none
    real, dimension(nr, nt) :: eqpsi1, eqth
    integer :: i, j

    do j=1,nt
       do i=1,nr
          eqpsi1(i,j) = eqpsi(i)
          eqth(i,j) = (j-1)*pi/float(nt-1)
       enddo
    enddo

    call derm(eqth,   dtm,  'T')
    call derm(R_psi,  drm,  'E')
    call derm(Z_psi,  dzm,  'O')
    call derm(B_psi,  dbm,  'E')
    call derm(eqpsi1, dpm,  'E')

! grad(psi) in cartesian form
    call eqdcart(dpm, dpcart)
! grad(psi) in Bishop form
    call eqdbish(dpcart, dpbish)

! grad(B) in cartesian form
    call eqdcart(dbm, dbcart)
! grad(B) in Bishop form
    call eqdbish(dbcart, dbbish)

! grad(BT) in cartesian form
    dbtcart = 0.
! grad(BT) in Bishop form
    dbtbish = 0.

! grad(theta) in cartesian form
    call eqdcart(dtm, dtcart)
! grad(theta) in Bishop form
    call eqdbish(dtcart, dtbish)
!    do i = 1, nw
!       do j = 1,nh
!          if(dfit_Z(j) == Z_mag .and. dfit_R(i) == R_mag) then
!             eqth(i,j) = 0.  ! value should not matter
!          else
!             eqth(i,j) = atan2( (dfit_Z(j)-Z_mag), (dfit_R(i)-R_mag))
!          endif
!       enddo
!    enddo

!    call derm(dfit_psi, dpm)
!    call tderm(eqth, dtm)
  end subroutine dfit_init

  subroutine derm(f, dfm, char)
    use constants, only: pi
    implicit none
    real, dimension(:,:), intent(in) :: f
    real, dimension(:,:,:), intent(out) :: dfm
    character(1), intent(in) :: char
    integer :: i, j

    i=1
    dfm(i,:,1) = -0.5*(3*f(i,:)-4*f(i+1,:)+f(i+2,:))

    i=nr
    dfm(i,:,1) = 0.5*(3*f(i,:)-4*f(i-1,:)+f(i-2,:))

!!! this is a bad assumption
! assume up-down symmetry for now:

    select case (char)
    case ('E')
       j=1
       dfm(:,j,2) = 0.5*(f(:,j+1)-f(:,j+1))

       j=nt
       dfm(:,j,2) = -0.5*(f(:,j-1)-f(:,j-1))
    case ('O')
       j=1
       dfm(:,j,2) = 0.5*(f(:,j+1)+f(:,j+1))

       j=nt
       dfm(:,j,2) = -0.5*(f(:,j-1)+f(:,j-1))
    case ('T')
       j=1
       dfm(:,j,2) = f(:,j+1)

       j=nt
       dfm(:,j,2) = pi - f(:,j-1)
    end select

    do i=2,nr-1
       dfm(i,:,1)=0.5*(f(i+1,:)-f(i-1,:))
    enddo

    do j=2,nt-1
       dfm(:,j,2)=0.5*(f(:,j+1)-f(:,j-1))
    enddo
  end subroutine derm

  subroutine gradient(rgrid, theta, grad, char, rp, nth_used, ntm)
    use splines, only: inter_d_cspl
    implicit none
    integer, intent (in) :: nth_used, ntm
    character(1), intent (in) :: char
    real, dimension(-ntm:), intent(in) :: rgrid, theta
    real, dimension(-ntm:,:), intent(out) :: grad
    real, intent(in) :: rp
    real, dimension (nr, nt, 2) :: dcart
    real, dimension (2) :: tmp
    real, dimension (1) :: aa, daa, rpt
    integer :: i

    select case(char)
    case('B')
       dcart = dbcart
    case('D')  ! diagnostic
       dcart = dbtcart
    case('P')
       dcart = dpcart
    case('R')
       dcart = dpcart  ! dpcart is correct for 'R'
    case('T')
       dcart = dtcart
    end select

    do i=-nth_used,-1
       call eqitem(rgrid(i), theta(i), dcart(:,:,1), tmp(1), 'R')
       call eqitem(rgrid(i), theta(i), dcart(:,:,2), tmp(2), 'Z')
       if(char == 'T') then
          grad(i,1)=-tmp(1)
          grad(i,2)=-tmp(2)
       else
          grad(i,1)=tmp(1)
          grad(i,2)=tmp(2)
       endif
    enddo

    do i=0,nth_used
       call eqitem(rgrid(i), theta(i), dcart(:,:,1), tmp(1), 'R')
       call eqitem(rgrid(i), theta(i), dcart(:,:,2), tmp(2), 'Z')
       grad(i,1)=tmp(1)
       grad(i,2)=tmp(2)
    enddo

!     to get grad(pressure), multiply grad(psi) by dpressure/dpsi

    if(char == 'R') then
       rpt(1) = rp
       call inter_d_cspl(nr, eqpsi, pressure, 1, rpt, aa, daa)
       do i=-nth_used, nth_used
          grad(i,1)=grad(i,1)*daa(1) * 0.5*beta_0
          grad(i,2)=grad(i,2)*daa(1) * 0.5*beta_0
       enddo
    endif
  end subroutine gradient

  subroutine bgradient(rgrid, theta, grad, char, rp, nth_used, ntm)
    use splines, only: inter_d_cspl
    implicit none
    integer, intent (in) :: nth_used, ntm
    character(1), intent (in) :: char
    real, dimension (-ntm:), intent (in)  ::  rgrid, theta
    real, dimension (-ntm:,:), intent (out) :: grad
    real, intent(in) :: rp
    real, dimension (1) :: aa, daa, rpt
    real, dimension(nr, nt, 2) ::  dbish
    integer :: i

    select case(char)
    case('B')
       dbish = dbbish
    case('D')  ! diagnostic
       dbish = dbtbish
    case('P')
       dbish = dpbish
    case('R')
       dbish = dpbish  ! dpcart is correct for 'R'
    case('T')
       dbish = dtbish
    end select

    do i=-nth_used,nth_used
       call eqitem(rgrid(i), theta(i), dbish(:,:,1), grad(i,1), 'R')
       call eqitem(rgrid(i), theta(i), dbish(:,:,2), grad(i,2), 'Z')
    enddo

    if (char == 'T') then
       where (theta(-nth_used:nth_used) < 0.0)
          grad(-nth_used:nth_used,1) = -grad(-nth_used:nth_used,1)
          grad(-nth_used:nth_used,2) = -grad(-nth_used:nth_used,2)
       end where
    end if

!     to get grad(pressure), multiply grad(psi) by dpressure/dpsi

    if(char == 'R') then
       rpt(1) = rp
       call inter_d_cspl(nr, eqpsi, pressure, 1, rpt, aa, daa)
       do i=-nth_used, nth_used
          grad(i,1)=grad(i,1)*daa(1) * 0.5*beta_0
          grad(i,2)=grad(i,2)*daa(1) * 0.5*beta_0
       enddo
    endif
  end subroutine bgradient

  subroutine eqitem(r_in, theta_in, f, fstar, char)
    use constants, only: pi
    use mp, only: mp_abort
    real, intent(in) :: r_in
    real, intent(in) :: theta_in
    real, dimension(:,:), intent(in) :: f
    real, intent(out) :: fstar
    character(1), intent(in) :: char
    integer :: i, j, istar, jstar
    real :: thet, sign, tp, tps, r
    real :: st, dt, sr, dr, rt
    real, dimension(size(f,2)) :: mtheta

    !Copy value to avoid any modification
    r=r_in

! check for axis evaluation

    if(r == eqpsi(1)) then
       write(*,*) 'no evaluation at axis allowed in eqitem'
       write(*,*) r, theta_in, eqpsi(1)
       call mp_abort('no evaluation at axis allowed in eqitem')
    endif

! allow psi(r) to be a decreasing function

    sign=1.
    if(eqpsi(2) < eqpsi(1)) sign=-1.

    if(r < sign*eqpsi(1)) then
       write(*,*) 'r < Psi_0 in eqitem'
       write(*,*) r,sign,eqpsi(1)
       call mp_abort('r < Psi_0 in eqitem')
    endif

! find r on psi mesh

! disallow evaluations outside the plasma surface for now
    if(r == eqpsi(nr)) then
       rt = 0.9999999999*r
       if(rt > eqpsi(nr)) rt = 1.0000000001*r
       r = rt
    endif

    if(r >= eqpsi(nr)) then
       write(*,*) 'No evaluation of eqitem allowed outside surface'
       write(*,*) r, theta_in, eqpsi(nr), sign
       call mp_abort('No evaluation of eqitem allowed outside surface')
    endif

    istar=0
    do i=2,nr
       if(r < sign*eqpsi(i)) then
          dr = r - sign*eqpsi(i-1)
          sr = sign*eqpsi(i) - r
          istar=i-1
          exit
       endif
    enddo

! no gradients available at axis, so do not get too close

    if(istar == 1) then
!       write(*,*) 'Too close to axis in eqitem'
!       write(*,*) r, theta_in, eqpsi(1), eqpsi(2)
!       call mp_abort('Too close to axis in eqitem')
    endif

! Now do theta direction

    thet = mod2pi(theta_in)

! assume up-down symmetry

    tp=abs(thet)
    tps=1.
    if(char == 'Z' .and. tp >= 1.e-10) tps=thet/tp

! get thet on theta mesh

    do j=1,nt
       mtheta(j)=(j-1)*pi/float(nt-1)
    enddo

! note that theta(1)=0 for gen_eq theta

    jstar=-1
    do j=1,nt
       if(jstar /= -1) cycle
       if(tp < mtheta(j)) then
          dt = tp - mtheta(j-1)
          st = mtheta(j) - tp
          jstar=j-1
       endif
    enddo

! treat theta = pi separately

    if(jstar == -1) then
       jstar=nt-1
       dt=mtheta(jstar+1)-mtheta(jstar)
       st=0.
    endif

! use opposite area stencil to interpolate

!    if(char == 'R') i=1
!    if(char == 'Z') i=2
    fstar=f(istar    , jstar    ) * sr * st &
         +f(istar + 1, jstar    ) * dr * st &
         +f(istar    , jstar + 1) * sr * dt &
         +f(istar + 1, jstar + 1) * dr * dt
    fstar=fstar*tps &
         /abs(eqpsi(istar+1)-eqpsi(istar)) &
         /(mtheta(jstar+1)-mtheta(jstar))
!     write(*,*) i, dr, dt, sr, st
!     write(*,*) f(istar,jstar+1),f(istar+1,jstar+1)
!     write(*,*) f(istar,jstar),f(istar+1,jstar)
!     write(*,*) eqpsi(istar),eqpsi(istar+1)
!     write(*,*) mtheta(jstar),mtheta(jstar+1)

  end subroutine eqitem

  subroutine eqdcart(dfm, dfcart)

    implicit none

    real, dimension (:,:,:), intent(in)  :: dfm
    real, dimension (:,:,:), intent(out) :: dfcart
    real, dimension (size(dfm,1),size(dfm,2)) :: denom
    integer :: i, j

    denom(:,:) = drm(:,:,1)*dzm(:,:,2) - drm(:,:,2)*dzm(:,:,1)

    dfcart(:,:,1) =   dfm(:,:,1)*dzm(:,:,2) - dzm(:,:,1)*dfm(:,:,2)
    dfcart(:,:,2) = - dfm(:,:,1)*drm(:,:,2) + drm(:,:,1)*dfm(:,:,2)

    do j=1,nt
       do i=2,nr
          dfcart(i,j,:)=dfcart(i,j,:)/denom(i,j)
       enddo
    enddo
  end subroutine eqdcart

  subroutine eqdbish(dcart, dbish)
    implicit none
    real, dimension(:, :, :), intent (in) :: dcart
    real, dimension(:, :, :), intent(out) :: dbish
    real, dimension(size(dcart,1),size(dcart,2)) :: denom
    integer :: i, j

    denom(:,:) = sqrt(dpcart(:,:,1)**2 + dpcart(:,:,2)**2)

    dbish(:,:,1) = dcart(:,:,1)*dpcart(:,:,1) + dcart(:,:,2)*dpcart(:,:,2)
    dbish(:,:,2) =-dcart(:,:,1)*dpcart(:,:,2) + dcart(:,:,2)*dpcart(:,:,1)

    do j=1,nt
       do i=2,nr
          dbish(i,j,:) = dbish(i,j,:)/denom(i,j)
       enddo
    enddo
  end subroutine eqdbish

  function initialize_invR (init)
    integer, intent(in) :: init
    integer :: initialize_invR

    init_invR = .false.
    if(init == 1) init_invR = .true.
    initialize_invR = 1
  end function initialize_invR

  function invR (r, theta)
    real, intent (in) :: r, theta
    real :: f, invR
    real :: th

    th = mod2pi( theta)

    call eqitem(r, th, R_psi, f, 'R')
    invR=1./f
  end function invR

  function Rpos (r, theta)
    real, intent (in) :: r, theta
    real :: f, Rpos
    real :: th

    th = mod2pi( theta)

    call eqitem(r, th, R_psi, f, 'R')
    Rpos=f
  end function Rpos

  function Zpos (r, theta)
    real, intent (in) :: r, theta
    real :: f, Zpos
    real :: th

    th = mod2pi( theta)

    call eqitem(r, th, Z_psi, f, 'Z')
    Zpos=f
  end function Zpos

  function initialize_psi (init)
    integer, intent(in) :: init
    integer :: initialize_psi

    init_psi = .false.
    if(init == 1) init_psi = .true.
    initialize_psi = 1
  end function initialize_psi

  function psi (r)
    real, intent (in) :: r
    real :: psi

    psi = r
  end function psi

  function mod2pi (theta)
    use constants, only: pi
    real, intent(in) :: theta
    real :: th, mod2pi
    logical :: out

    if(theta <= pi .and. theta >= -pi) then
       mod2pi = theta
       return
    endif

    th=theta
    out=.true.
    do while(out)
       if(th > pi) th = th - 2.*pi
       if(th <-pi) th = th + 2.*pi
       if(th <= pi .and. th >= -pi) out=.false.
    enddo
    mod2pi=th
  end function mod2pi

  function initialize_diameter (init)
    integer, intent(in) :: init
    integer :: initialize_diameter

    init_diameter = .false.
    if(init == 1) init_diameter = .true.
    initialize_diameter = 1
  end function initialize_diameter

  function diameter (rp)
! not really the diameter in this case.  Instead, return the
! normalized minor radius, measured inside the ring, in the plane of
! the ring, starting at the ring and going inward.
    use splines, only: new_spline, splint, spline
    real, intent(in) :: rp
    real :: diameter
    type (spline), save :: spl

    if(init_diameter) then
       diam = rho_d
       call new_spline(nr, eqpsi, diam, spl)
       init_diameter = .false.
    endif

    diameter = splint(rp, spl)
  end function diameter

  function initialize_rcenter (init)
    integer, intent(in) :: init
    integer :: initialize_rcenter

    init_rcenter = .false.
    if(init == 1) init_rcenter = .true.
    initialize_rcenter = 1
  end function initialize_rcenter

  function rcenter (rp)
    use splines, only: new_spline, splint, spline
    real, intent(in) :: rp
    real :: rcenter
    type (spline), save :: spl

    if(init_rcenter) then
       rc(:) = 0.5*(R_psi(:,1)+R_psi(:,(nt-1)/2))
       call new_spline(nr, eqpsi, rc, spl)
       init_rcenter = .false.
    endif

    rcenter = splint(rp, spl)
  end function rcenter

  function initialize_dbtori (init)
    integer, intent(in) :: init
    integer :: initialize_dbtori

    init_dbtori = .false.
    if(init == 1) init_dbtori = .true.
    initialize_dbtori = 1
  end function initialize_dbtori

  function dbtori ()
    real :: dbtori

    dbtori = 0.
  end function dbtori

  function initialize_btori (init)
    integer, intent(in) :: init
    integer :: initialize_btori

    init_btori = .false.
    if(init == 1) init_btori = .true.
    initialize_btori = 1
  end function initialize_btori

  function btori ()
    real :: btori

    btori = 0.
  end function btori

  function initialize_q (init)
    integer, intent(in) :: init
    integer :: initialize_q

    init_q = .false.
    if(init == 1) init_q = .true.
    initialize_q = 1
  end function initialize_q

  function qfun ()
    real :: qfun

    qfun = 0.
  end function qfun

  function initialize_pressure (init)
    integer, intent(in) :: init
    integer :: initialize_pressure

    init_pressure = .false.
    if(init == 1) init_pressure = .true.
    initialize_pressure = 1
  end function initialize_pressure

  function pfun (pbar)
    use splines, only: new_spline, splint, spline
    implicit none
    real, intent(in) :: pbar
    real :: pfun
    type (spline), save :: spl

    if(init_pressure) call new_spline(nr, psi_bar, pressure, spl)
    init_pressure = .false.
!
! p_N would be B**2/mu_0 => p = beta/2 in our units
!
    pfun = 0.5*beta_0*splint(pbar, spl)
  end function pfun

  function initialize_dpressure (init)
    integer, intent(in) :: init
    integer :: initialize_dpressure

    init_dpressure = .false.
    if(init == 1) init_dpressure = .true.
    initialize_dpressure = 1
  end function initialize_dpressure

  function dpfun (pbar)
    use splines, only: new_spline, dsplint, spline
    implicit none
    real, intent(in) :: pbar
    real :: dpfun
    type (spline), save :: spl
!
! p_N would be B**2/mu_0 => p = beta/2 in our units
!
    if(init_dpressure) then
       call new_spline(nr, psi_bar, pressure, spl)
       init_dpressure = .false.
    endif

    dpfun = dsplint(pbar, spl)/(psi_a-psi_0) * beta_0/2.
  end function dpfun

  function initialize_beta (init)
    integer, intent(in) :: init
    integer :: initialize_beta

    init_beta = .false.
    if(init == 1) init_beta = .true.
    initialize_beta = 1
  end function initialize_beta

  function betafun (pbar)
    use splines, only: new_spline, splint, spline
    implicit none
    real, intent(in) :: pbar
    real :: betafun
    type (spline), save :: spl

    if(pbar == 0.) then
       betafun=beta(1)
       return
    endif

    if(init_beta) call new_spline(nr, psi_bar, beta, spl)
    init_beta = .false.

    betafun = splint(pbar, spl)
  end function betafun

!Could we use the sorting module here?
  subroutine sort(a, b, c, d)
    real, dimension(:), intent(in out) :: a, b, c, d
    real tmp
    integer :: i, j, jmax

    jmax = size(a)

    do j=1,jmax
       do i=1,jmax-j
          if(a(i+1) < a(i)) then
             tmp=a(i); a(i)=a(i+1); a(i+1)=tmp
             tmp=b(i); b(i)=b(i+1); b(i+1)=tmp
             tmp=c(i); c(i)=c(i+1); c(i+1)=tmp
             tmp=d(i); d(i)=d(i+1); d(i+1)=tmp
          endif
       enddo
    enddo
  end subroutine sort
end module ideq


!     This routine computes equivalent reflectivity factor (in dBZ) at
!     each model grid point.  In calculating Ze, the RIP algorithm makes
!     assumptions consistent with those made in an early version
!     (ca. 1996) of the bulk mixed-phase microphysical scheme in the MM5
!     model (i.e., the scheme known as "Resiner-2").  For each species:
!
!     1. Particles are assumed to be spheres of constant density.  The
!     densities of rain drops, snow particles, and graupel particles are
!     taken to be rho_r = rho_l = 1000 kg m^-3, rho_s = 100 kg m^-3, and
!     rho_g = 400 kg m^-3, respectively. (l refers to the density of
!     liquid water.)
!
!     2. The size distribution (in terms of the actual diameter of the
!     particles, rather than the melted diameter or the equivalent solid
!     ice sphere diameter) is assumed to follow an exponential
!     distribution of the form N(D) = N_0 * exp( lambda*D ).
!
!     3. If ivarint=0, the intercept parameters are assumed constant
!     (as in early Reisner-2), with values of 8x10^6, 2x10^7,
!     and 4x10^6 m^-4, for rain, snow, and graupel, respectively.
!     If ivarint=1, variable intercept parameters are used, as
!     calculated in Thompson, Rasmussen, and Manning (2004, Monthly
!     Weather Review, Vol. 132, No. 2, pp. 519-542.)
!
!     4. If iliqskin=1, frozen particles that are at a temperature above
!     freezing are assumed to scatter as a liquid particle.
!
!     More information on the derivation of simulated reflectivity in
!     RIP can be found in Stoelinga (2005, unpublished write-up).
!     Contact Mark Stoelinga (stoeling@atmos.washington.edu) for a copy.

!NCLFORTSTART
SUBROUTINE CALCDBZ(prs, tmk, qvp, qra, qsn, qgr, sn0, ivarint, iliqskin, dbz, nx, ny, nz)
    USE wrf_constants, ONLY : GAMMA_SEVEN, RHOWAT, RHO_R, RHO_S, RHO_G, ALPHA, &
                          CELKEL, PI, RD

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: dbz

    !   Arguments
    INTEGER, INTENT(IN) :: nx, ny, nz
    INTEGER, INTENT(IN) :: sn0, ivarint, iliqskin
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(OUT) :: dbz
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: prs
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: tmk
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(INOUT) :: qvp
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(INOUT) :: qra
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(INOUT) :: qsn
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(INOUT) :: qgr

!NCLEND

    !   Local Variables
    INTEGER :: i, j, k
    REAL(KIND=8) :: temp_c, virtual_t
    REAL(KIND=8) :: gonv, ronv, sonv
    REAL(KIND=8) :: factor_g, factor_r, factor_s
    REAL(KIND=8) :: factorb_g, factorb_s
    REAL(KIND=8) :: rhoair, z_e

    !   Constants used to calculate variable intercepts
    REAL(KIND=8), PARAMETER :: R1 = 1.D-15
    REAL(KIND=8), PARAMETER :: RON = 8.D6
    REAL(KIND=8), PARAMETER :: RON2 = 1.D10
    REAL(KIND=8), PARAMETER :: SON = 2.D7
    REAL(KIND=8), PARAMETER :: GON = 5.D7
    REAL(KIND=8), PARAMETER :: RON_MIN = 8.D6
    REAL(KIND=8), PARAMETER :: RON_QR0 = 0.00010D0
    REAL(KIND=8), PARAMETER :: RON_DELQR0 = 0.25D0*RON_QR0
    REAL(KIND=8), PARAMETER :: RON_CONST1R = (RON2-RON_MIN)*0.5D0
    REAL(KIND=8), PARAMETER :: RON_CONST2R = (RON2+RON_MIN)*0.5D0

    !   Constant intercepts
    REAL(KIND=8), PARAMETER :: RN0_R = 8.D6
    REAL(KIND=8), PARAMETER :: RN0_S = 2.D7
    REAL(KIND=8), PARAMETER :: RN0_G = 4.D6

    !$OMP PARALLEL

    !   Force all Q arrays to be 0.0 or greater.
    !$OMP DO COLLAPSE(3) SCHEDULE(runtime)
    DO k = 1,nz
        DO j = 1,ny
            DO i = 1,nx
                IF (qvp(i,j,k) .LT. 0.0) THEN
                    qvp(i,j,k) = 0.0
                END IF
                IF (qra(i,j,k) .LT. 0.0) THEN
                    qra(i,j,k) = 0.0
                END IF
                IF (qsn(i,j,k) .LT. 0.0) THEN
                    qsn(i,j,k) = 0.0
                END IF
                IF (qgr(i,j,k) .LT. 0.0) THEN
                    qgr(i,j,k) = 0.0
                END IF
            END DO
        END DO
    END DO
    !$OMP END DO

    !   Input pressure is Pa, but we need hPa in calculations

    IF (sn0 .EQ. 0) THEN
        !$OMP DO COLLAPSE(3) SCHEDULE(runtime)
        DO k = 1,nz
            DO j = 1,ny
                DO i = 1,nx
                    IF (tmk(i,j,k) .LT. CELKEL) THEN
                        qsn(i,j,k) = qra(i,j,k)
                        qra(i,j,k) = 0.D0
                    END IF
                END DO
            END DO
        END DO
        !$OMP END DO
    END IF

    factor_r = GAMMA_SEVEN*1.D18*(1.D0/(PI*RHO_R))**1.75D0
    factor_s = GAMMA_SEVEN*1.D18*(1.D0/(PI*RHO_S))**1.75D0*(RHO_S/RHOWAT)**2*ALPHA
    factor_g = GAMMA_SEVEN*1.D18*(1.D0/(PI*RHO_G))**1.75D0*(RHO_G/RHOWAT)**2*ALPHA

    !$OMP DO COLLAPSE(3) PRIVATE(i, j, k, temp_c, virtual_t, gonv, ronv, sonv, &
    !$OMP factorb_g, factorb_s, rhoair, z_e) &
    !$OMP FIRSTPRIVATE(factor_r, factor_s, factor_g) SCHEDULE(runtime)
    DO k = 1,nz
        DO j = 1,ny
            DO i = 1,nx
                virtual_t = tmk(i,j,k)*(0.622D0 + qvp(i,j,k))/(0.622D0*(1.D0 + qvp(i,j,k)))
                rhoair = prs(i,j,k)/(RD*virtual_t)

                ! Adjust factor for brightband, where snow or graupel particle
                ! scatters like liquid water (alpha=1.0) because it is assumed to
                ! have a liquid skin.
                IF (iliqskin .EQ. 1 .AND. tmk(i,j,k) .GT. CELKEL) THEN
                    factorb_s = factor_s/ALPHA
                    factorb_g = factor_g/ALPHA
                ELSE
                    factorb_s = factor_s
                    factorb_g = factor_g
                END IF

                ! Calculate variable intercept parameters
                IF (ivarint .EQ. 1) THEN

                    temp_c = MIN(-0.001D0, tmk(i,j,k)-CELKEL)
                    sonv = MIN(2.0D8, 2.0D6*EXP(-0.12D0*temp_c))

                    gonv = gon
                    IF (qgr(i,j,k) .GT. R1) THEN
                        gonv = 2.38D0 * (PI*RHO_G/(rhoair*qgr(i,j,k)))**0.92D0
                        gonv = MAX(1.D4, MIN(gonv,GON))
                    END IF

                    ronv = RON2
                    IF (qra(i,j,k) .GT. R1) THEN
                        ronv = RON_CONST1R*TANH((RON_QR0 - qra(i,j,k))/RON_DELQR0) + RON_CONST2R
                    END IF

                ELSE
                    ronv = RN0_R
                    sonv = RN0_S
                    gonv = RN0_G
                END IF

                ! Total equivalent reflectivity factor (z_e, in mm^6 m^-3) is
                ! the sum of z_e for each hydrometeor species:

                z_e = factor_r*(rhoair*qra(i,j,k))**1.75D0/ronv**.75D0 + &
                      factorb_s*(rhoair*qsn(i,j,k))**1.75D0/sonv**.75D0 + &
                      factorb_g*(rhoair*qgr(i,j,k))**1.75D0/gonv**.75D0

                ! Adjust small values of Z_e so that dBZ is no lower than -30
                z_e = MAX(z_e, .001D0)

                ! Convert to dBZ
                dbz(i,j,k) = 10.D0*LOG10(z_e)
            END DO
        END DO
    END DO
    !$OMP END DO

    !$OMP END PARALLEL

    RETURN

END SUBROUTINE CALCDBZ


      subroutine ogden_elasticity(matData,mu,alpha,F,sig,cc,finite)

      implicit none

      integer          finite,
     *                 nOgd, i, l, m, n, round,
     *                 spectralDecomposition
      double precision matData(*), mu(*), alpha(*), F(3,*), sig(*),
     *                 cc(6,*),
     *                 matDataSmall(2), K, b(6), lam2(3), dtau(3,3),
     *                 tau6(6), h4(6,6), J, lam(3), lampa(3), press,
     *                 tau(3), fact, fact2, E(6,3),
     *                 r1, r1d2, r1d3, r1d6

      r1   = 1.d0
      r1d2 = 0.5d0
      r1d3 = r1 / 3.d0
      r1d6 = r1d3 * r1d2

      K    = matData(1)
      nOgd = round(matData(2))

      if (finite.lt.1) then
        matDataSmall(1) = 0.d0
        do i=1, nOgd
          matDataSmall(1) = matDataSmall(1) + mu(i) * alpha(i)
        enddo
        matDataSmall(1) = matDataSmall(1) * 0.5d0
        matDataSmall(2) = K
        call small_strain_elasticity(matDataSmall,F,sig,cc)
        return
      endif

      call calcB(b,F)

      if (spectralDecomposition(lam2,E,b).ne.1)

     *   call prgError(1,"ogden_elasticity","fatal error!")

      lam(1) = sqrt(lam2(1))
      lam(2) = sqrt(lam2(2))
      lam(3) = sqrt(lam2(3))

      J = lam(1) * lam(2) * lam(3)

      call pzero(tau,3)
      call pzero(dtau,9)

      do i=1, nOgd

        !write(*,*) mu(i), alpha(i)

        lampa(1) = lam(1)**alpha(i)
        lampa(2) = lam(2)**alpha(i)
        lampa(3) = lam(3)**alpha(i)

        fact2    = mu(i) * J**(-alpha(i)*r1d3) * r1d6

        do l=1, 3

          m = l + 1
          if (m .eq. 4) m = 1
          n = m + 1
          if (n .eq. 4) n = 1

          fact  = lampa(l) + lampa(l) - lampa(m) - lampa(n)

          tau(l) = tau(l) + (fact2 + fact2) * fact

          dtau(l,l) = dtau(l,l) + fact2 * alpha(i) / lam2(l) *
     *                         (lampa(l) + lampa(l) - r1d3 * fact)

          dtau(l,m) = dtau(l,m) - fact2 * alpha(i) / lam2(m) *
     *                         (lampa(m)            + r1d3 * fact)

          dtau(l,n) = dtau(l,n) - fact2 * alpha(i) / lam2(n) *
     *                         (lampa(n)            + r1d3 * fact)

        enddo

      enddo

      call isotropicTensorFunction(tau6,h4,lam2,tau,dtau,E,b)

      call pzero(sig,6)
      call pzero(cc,36)

      call taub2sigccPart1(sig,cc,tau6,h4,b,J)

c...  compute volumetric response (pressure)

      press = r1d2 * K * (J - r1/J)
      fact  = K * J
      do i=1, 3
        sig(i)  = sig(i)  + press
        cc(i,1) = cc(i,1) + fact
        cc(i,2) = cc(i,2) + fact
        cc(i,3) = cc(i,3) + fact
      enddo

c...  add geometrical part to tangent tensor

      call taub2sigccPart2(sig,cc)

      return

      end


 SUBROUTINE corr17(st11,st22,st12,st33,efpst,gm,props,b, &
                   ierr,ep,flag,is,ielem,np,curve)
 !-------------------------------------------------------------------
 !
 !     transversal Anisotropy for 2-D Plane Strain
 !
 !-------------------------------------------------------------------
 USE lispa0
 USE mat_dba, ONLY : inte_cr
 IMPLICIT NONE

 REAL (kind=8),INTENT(IN) :: props(:),  & !material properties
                             gm,        & !elasticity shear modulus
                             b(:)         !flow rule matrix
 REAL (kind=8),INTENT(IN OUT) :: st11,st22,st12,st33   !trial and corrected stresses
 REAL (kind=8),INTENT(IN OUT) :: efpst    !effective plastic strain
                                          !(IN) present   (OUT) increment
 REAL (kind=8), POINTER :: curve(:,:)     !(3,np) yield stress
 REAL (kind=8),INTENT(OUT) :: ep(4)       !increment in plastic strains
 INTEGER (kind=4), INTENT(IN) :: is,    & !isotropic hardening model
                                 ielem    !element number
 INTEGER (kind=4), INTENT(IN) :: np       !number of points in CURVE
 INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)
 LOGICAL, INTENT(OUT) :: flag             !.TRUE. if plastic  .FALSE. if elastic

 !local variables

  REAL (kind=8) :: c0,c1,c2,c3,aprim
  REAL (kind=8) :: s11,s22,s12,s33,yield,epbar,fi,f0,a1,a2,a3,a4, &
                   ap,dl,aux

  REAL (kind=8), PARAMETER :: toler=1d-4, toler1=1d-6
  INTEGER (kind=4), PARAMETER :: miter=5

  INTEGER (kind=4) k
  !INTEGER (kind=4), SAVE :: kk(miter) = 0

 !------------ begin

 !     setup initial yield FUNCTION radius
 IF( is == 5 ) THEN        !for points defined yield value
   k = 1   !begin at first interval
   c0 = inte_cr (curve,np,efpst,k)
   c1 = curve(3,k)
   c0 = c0 - c1 * efpst
 ELSE
   c0 = props(1)     !c0 constant or Initial yield
   c1 = props(2)     !linear hardening or efref
   c2 = props(3)     !exponent for non-linear hardening
   c3 = props(4)     !residual flow stress
 END IF

  CALL isoha14(is,yield,aprim,efpst,c0,c1,c2,c3)

  !     calculate initial effective stress

  a1 = b(1)*st11 + b(2)*st22 + b(5)*st33
  a2 = b(2)*st11 + b(3)*st22 + b(6)*st33
  a3 = b(4)*st12
  a4 = b(5)*st11 + b(6)*st22 + b(7)*st33

  fi = SQRT(ABS(a1*st11 + a2*st22 + a3*st12 + a4*st33))

  !     check initial yield FUNCTION

  f0 = fi-yield
  IF((f0-toler*fi) <=  0d0) THEN

     !   IF the point is elastic

    flag = .FALSE.       !no plastic flow

  ELSE
    !  initial flow rule

    !   start iteration for satisfying consistency condition
    s11 = st11
    s22 = st22
    s12 = st12
    s33 = st33
    epbar = efpst
    DO k = 1,miter
      ! compute flow rule
      a1 = a1/fi
      a2 = a2/fi
      a3 = a3/fi
      a4 = a4/fi
      ap = gm*(2d0*(a1*a1+a2*a2+a4*a4)+a3*a3)+aprim
      dl = f0/ap
      !   calculate the effective plastic strain
      epbar = epbar + dl
      ! new stres
      aux = dl*gm*2d0
      s11 = s11 - aux*a1
      s22 = s22 - aux*a2
      s12 = s12 - aux*a3/2d0
      s33 = s33 - aux*a4
      !   update the radius of the yield surface
      CALL isoha14(is,yield,aprim,epbar,c0,c1,c2,c3)
      !   calculate the effective stress
      a1 = b(1)*s11 + b(2)*s22 + b(5)*s33
      a2 = b(2)*s11 + b(3)*s22 + b(6)*s33
      a3 = b(4)*s12
      a4 = b(5)*s11 + b(6)*s22 + b(7)*s33
      fi = SQRT(a1*s11 + a2*s22 + a3*s12 + a4*s33 )
      f0 = fi-yield     !yield function
      !  IF consistency condition is satisfied exit loop
      IF( ABS(f0/yield) <= toler1 )EXIT
    END DO

    IF( k <= miter )THEN
      flag = .TRUE.
      ! increments in plastic strains (twice de deviatoric tensor)
      ep(1) = (st11 - s11)/gm
      ep(2) = (st22 - s22)/gm
      ep(3) = (st12 - s12)/gm
      ep(4) = (st33 - s33)/gm
      !  assign corrected stresses
      st11 = s11
      st22 = s22
      st12 = s12
      st33 = s33
      efpst = epbar - efpst              !increment in effective plastic strain
      !efpst = ((ep(1)*s11+ep(2)*s22+ep(4)*s33)/2d0+ep(3)*s12)/yield
      !kk(k) = kk(k) + 1
      !k = SUM(kk)
      !IF( MOD(k,100000) == 0 )THEN
      !  WRITE(55,"(5i10)")kk
      !  kk = 0
      !END IF

    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      WRITE(58,"('error in element ',i6)")ielem    !print element number
      ierr=1                 !set flag to error in plastic integration
    END IF
  END IF

  RETURN

 END SUBROUTINE corr17


      subroutine run_iiii(j,i1,i2,i3,i4,DetGr,Xtwiddle0,Gtwiddle,
     . Shat5,N0)
C---Fixes Diiii according to extension of Denner-Dittmaier
C---knowing D00iii and dropping terms of order Delta Diiiii
      implicit none
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,j,i1,i2,i3,i4,n
      double precision DetGr,Xtwiddle0(3),Gtwiddle(3,3)
      double complex Shat5(3,z4max,-2:0),Shat5s(3,z4max,-2:0)

      do ep=-2,0
      do n=1,3
      Shat5s(n,z4(i1,i2,i3,i4),ep)=Shat5(n,z4(i1,i2,i3,i4),ep)
     .   -2d0*(delta(n,i1)*Dv(N0+dzziii(z3(i2,i3,i4)),ep)
     .        +delta(n,i2)*Dv(N0+dzziii(z3(i1,i3,i4)),ep)
     .        +delta(n,i3)*Dv(N0+dzziii(z3(i1,i2,i4)),ep)
     .        +delta(n,i4)*Dv(N0+dzziii(z3(i1,i2,i3)),ep))
      enddo

      Dv(diiii(z4(i1,i2,i3,i4))+N0,ep)=-(
     . +Gtwiddle(j,1)*Shat5s(1,z4(i1,i2,i3,i4),ep)
     . +Gtwiddle(j,2)*Shat5s(2,z4(i1,i2,i3,i4),ep)
     . +Gtwiddle(j,3)*Shat5s(3,z4(i1,i2,i3,i4),ep)
     . -DetGr*Dv(diiiii(z5(j,i1,i2,i3,i4))+N0,ep))/Xtwiddle0(j)
      enddo

      return
      end


         implicit real*8 (a-h, o-z)
         dimension a(0:500,-500:500),b(0:500,-500:500)
         dimension f(0:500,0:500),fx(0:500,0:500),fy(0:500,0:500)
         dimension fxx(0:500,0:500),fyy(0:500,0:500),fxy(0:500,0:500)
         dimension dens(0:500,0:500),dfs(0:500,0:500),dfss(0:500,0:500)

            pi=4.d0*datan(1.d0)

            open(unit=10,file='f1.dat')
            open(unit=11,file='derivatives1.dat')
            open(unit=12,file='skf1.dat')

          print 1000
 1000     format('input number of modes, number of points :',',' )
          read *, Nk,NN

          print 1001
 1001     format('input two random numbers :',',' )
          read *, xr1,yr1

c          xr1=6378836631.d0
c          yr1=77833324111.d0
          xr2=0.d0
          yr2=0.d0
          xr3=0.d0
          yr3=0.d0
c---------random number generator-----------
          ar1=0.d0
          ar2=63308.d0
          ar3=-183326.d0
          br1=86098.d0
          br2=0.d0
          br3=-539608.d0
          do 1 k1=0,Nk
             do 2 k2=-Nk,Nk
               do 3 ng=1,2
                 do 4 nrr=1,2
          xr=ar1*xr1+ar2*xr2+ar3*xr3
          yr=br1*yr1+br2*yr2+br3*yr3

          xr=dmod(xr,2147483647.d0)
          yr=dmod(yr,2145483479.d0)

          xr3=xr2
          xr2=xr1
          xr1=xr

          yr3=yr2
          yr2=yr1
          yr1=yr

          rnd=dmod((xr-yr),2147483647.d0)/2147483647.d0
          rnd=dsqrt(rnd*rnd)

          if (nrr.eq.1) then
             rnd1=rnd
               else
             rnd2=rnd
           endif
 4              continue
              grnd =dsqrt(-2.d0*dlog(rnd1))*dcos(2.d0*pi*rnd2)

            if (ng.eq.1) then
               a(k1,k2)=grnd
                else
               b(k1,k2)=grnd
            endif
 3            continue

              print *, k1,k2,a(k1,k2),b(k1,k2)

 2           continue
 1         continue
c------------------------------------------------------

           a(0,0)=0.d0
           b(0,0)=0.d0

           h=2.d0*pi/dble(NN)
            s=0.d0
           do 5 j1=0,NN-1
              do 6 j2=0,NN-1
                 x=h*dble(j1)
                 y=h*dble(j2)
                 f(j1,j2)=0.d0
                 fx(j1,j2)=0.d0
                 fy(j1,j2)=0.d0
                 fxx(j1,j2)=0.d0
                 fyy(j1,j2)=0.d0
                 fxy(j1,j2)=0.d0
                 fxxx=0.d0
                 fyyy=0.d0
                 fxxy=0.d0
                 fxyy=0.d0
                 do 7 k1=0,Nk
                    do 8 k2=-Nk,Nk
                       arg=x*dble(k1)+y*dble(k2)
                       d1=dble(k1)
                       d2=dble(k2)
               f(j1,j2)=f(j1,j2)+
     *         a(k1,k2)*dcos(arg)+b(k1,k2)*dsin(arg)
               fx(j1,j2)=fx(j1,j2)-
     *         d1*a(k1,k2)*dsin(arg)+d1*b(k1,k2)*dcos(arg)
               fy(j1,j2)=fy(j1,j2)-
     *         d2*a(k1,k2)*dsin(arg)+d2*b(k1,k2)*dcos(arg)
               fxx(j1,j2)=fxx(j1,j2)-
     *         d1*d1*a(k1,k2)*dcos(arg)-d1*d1*b(k1,k2)*dsin(arg)
               fyy(j1,j2)=fyy(j1,j2)-
     *         d2*d2*a(k1,k2)*dcos(arg)-d2*d2*b(k1,k2)*dsin(arg)
               fxy(j1,j2)=fxy(j1,j2)-
     *         d1*d2*a(k1,k2)*dcos(arg)-d1*d2*b(k1,k2)*dsin(arg)
               f111=f111+
     *         d1*d1*d1*a(k1,k2)*dsin(arg)-d1*d1*d1*b(k1,k2)*dcos(arg)
               f222=f222+
     *         d2*d2*d2*a(k1,k2)*dsin(arg)-d2*d2*d2*b(k1,k2)*dcos(arg)
               f112=f112+
     *         d1*d1*d2*a(k1,k2)*dsin(arg)-d1*d1*d2*b(k1,k2)*dcos(arg)
               f122=f122+
     *         d1*d2*d2*a(k1,k2)*dsin(arg)-d1*d2*d2*b(k1,k2)*dcos(arg)

 8                  continue
 7               continue

                 f1=fx(j1,j2)
                 f2=fy(j1,j2)
                 f11=fxx(j1,j2)
                 f22=fyy(j1,j2)
                 f12=fxy(j1,j2)

                 dfs(j1,j2)=f1*f2*(f22-f11)+(f1*f1-f2*f2)*f12

                 dfss(j1,j2)=f2*f2*(f11*f11+f1*f111+f12*f12+f2*f112)+
     *                f1*f1*(f22*f22+f2*f222+f12*f12+f1*f122)-
     *           2.d0*f1*f2*(f12*(f11+f22)+f1*f112+f2*f122)

                 s=s+f(j1,j2)*f(j1,j2)/dble(NN)/dble(NN)

                 dens(j1,j2)=f11+f22

 6            continue
 5          continue

             ss=0.d0
            do 21 j1=0,NN-1
               do 22 j2=0,NN-1
                 x=h*dble(j1)/2.d0/pi
                 y=h*dble(j2)/2.d0/pi
                  f(j1,j2)=f(j1,j2)/dsqrt(s)
                  ss=ss+f(j1,j2)*f(j1,j2)/dble(NN)/dble(NN)
                  write(10,*) x,y,f(j1,j2)
                  write(11,*) fx(j1,j2),fy(j1,j2),
     *                 fxx(j1,j2),fyy(j1,j2),fxy(j1,j2)
                  write(12,*) dens(j1,j2),dfs(j1,j2),dfss(j1,j2)
 22            continue
 21          continue

             print *, ss

             close(10)
             close(11)
             close(12)

          stop
      end


!
! Copyright (C) 2001-2007 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!-----------------------------------------------------------------------
subroutine init_at_1()
  !-----------------------------------------------------------------------
  !
  ! This routine computes a table with the radial Fourier transform
  ! of the atomic wavefunctions.
  !
  USE kinds,      ONLY : dp
  USE atom,       ONLY : rgrid, msh
  USE constants,  ONLY : fpi
  USE cell_base,  ONLY : omega
  USE ions_base,  ONLY : ntyp => nsp
  USE us,         ONLY : tab_at, nqx, dq
  USE uspp_param, ONLY : upf
  USE mp_global,  ONLY : intra_bgrp_comm
  USE mp,         ONLY : mp_sum
  !
  implicit none
  !
  integer :: nt, nb, iq, ir, l, startq, lastq, ndm
  !
  real(DP), allocatable :: aux (:), vchi (:)
  real(DP) :: vqint, pref, q

  call start_clock ('init_at_1')

  ndm = MAXVAL (msh(1:ntyp))
  allocate (aux(ndm),vchi(ndm))

  !
  ! chiq = radial fourier transform of atomic orbitals chi
  !
  pref = fpi/sqrt(omega)
  ! needed to normalize atomic wfcs (not a bad idea in general and
  ! necessary to compute correctly lda+U projections)
  call divide (intra_bgrp_comm, nqx, startq, lastq)
  tab_at(:,:,:) = 0.d0
  do nt = 1, ntyp
     do nb = 1, upf(nt)%nwfc
        if (upf(nt)%oc(nb) >= 0.d0) then
           l = upf(nt)%lchi (nb)
           do iq = startq, lastq
              q = dq * (iq - 1)
              call sph_bes (msh(nt), rgrid(nt)%r, q, l, aux)
              do ir = 1, msh(nt)
                 vchi(ir) = upf(nt)%chi(ir,nb) * aux(ir) * rgrid(nt)%r(ir)
              enddo
              call simpson (msh(nt), vchi, rgrid(nt)%rab, vqint)
              tab_at (iq, nb, nt) = vqint * pref
           enddo
        endif
     enddo
 enddo
  call mp_sum ( tab_at, intra_bgrp_comm )

  deallocate(aux ,vchi)

  call stop_clock ('init_at_1')
  return

end subroutine init_at_1


!
!-----------------------------------------------------------------------
!     A C U R A T
!-----------------------------------------------------------------------
!
!     Coefficients of Slater integrals are square roots of
!   rational numbers.  To improve the accuaracy, certain commonly
!   occuring coefficients are improved to machine accuracy.
!
      REAL(KIND(0.0D0)) FUNCTION ACURAT (C)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE) , INTENT(IN) :: C
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NUM
      INTEGER , DIMENSION(11) :: DEN
      INTEGER :: I
      REAL(DOUBLE) :: D1, C2, PROD, EPS
!-----------------------------------------------
      DATA DEN/ 2, 3, 7, 9, 15, 35, 49, 175, 189, 315, 441/
      DATA D1/ 1.D0/
!
      C2 = C*C
      ACURAT = C
      IF (C < 0.) THEN
         DO I = 1, 11
            PROD = DEN(I)*C2
            NUM = NINT(PROD)
            EPS = DABS(NUM - PROD)/DEN(I)
            IF (EPS > 1.D-8) CYCLE
            IF (EPS == 0.) CYCLE
            ACURAT = DSQRT((NUM*D1)/DEN(I))
            ACURAT = -ACURAT
            RETURN
         END DO
      ELSE
         DO I = 1, 11
            PROD = DEN(I)*C2
            NUM = NINT(PROD)
            EPS = DABS(NUM - PROD)/DEN(I)
            IF (EPS > 1.D-8) CYCLE
            IF (EPS == 0.) CYCLE
            ACURAT = DSQRT((NUM*D1)/DEN(I))
            RETURN
         END DO
      ENDIF
      RETURN
      END FUNCTION ACURAT


      SUBROUTINE iau_C2IXYS ( X, Y, S, RC2I )
*+
*  - - - - - - - - - - -
*   i a u _ C 2 I X Y S
*  - - - - - - - - - - -
*
*  Form the celestial to intermediate-frame-of-date matrix given the CIP
*  X,Y and the CIO locator s.
*
*  This routine is part of the International Astronomical Union's
*  SOFA (Standards of Fundamental Astronomy) software collection.
*
*  Status:  support routine.
*
*  Given:
*     X,Y        d       Celestial Intermediate Pole (Note 1)
*     S          d       the CIO locator s (Note 2)
*
*  Returned:
*     RC2I     d(3,3)    celestial-to-intermediate matrix (Note 3)
*
*  Notes:
*
*  1) The Celestial Intermediate Pole coordinates are the x,y components
*     of the unit vector in the Geocentric Celestial Reference System.
*
*  2) The CIO locator s (in radians) positions the Celestial
*     Intermediate Origin on the equator of the CIP.
*
*  3) The matrix RC2I is the first stage in the transformation from
*     celestial to terrestrial coordinates:
*
*        [TRS]  =  RPOM * R_3(ERA) * RC2I * [CRS]
*
*               =  RC2T * [CRS]
*
*     where [CRS] is a vector in the Geocentric Celestial Reference
*     System and [TRS] is a vector in the International Terrestrial
*     Reference System (see IERS Conventions 2003), ERA is the Earth
*     Rotation Angle and RPOM is the polar motion matrix.
*
*  Called:
*     iau_IR       initialize r-matrix to identity
*     iau_RZ       rotate around Z-axis
*     iau_RY       rotate around Y-axis
*
*  Reference:
*
*     McCarthy, D. D., Petit, G. (eds.), IERS Conventions (2003),
*     IERS Technical Note No. 32, BKG (2004)
*
*  This revision:  2014 November 7
*
*  SOFA release 2020-07-21
*
*  Copyright (C) 2020 IAU SOFA Board.  See notes at end.
*
*-----------------------------------------------------------------------

      IMPLICIT NONE

      DOUBLE PRECISION X, Y, S, RC2I(3,3)

      DOUBLE PRECISION R2, E, D

* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

*  Obtain the spherical angles E and d.
      R2 = X*X+Y*Y
      IF ( R2.GT.0D0 ) THEN
         E = ATAN2 ( Y, X )
      ELSE
         E = 0D0
      END IF
      D = ATAN ( SQRT ( R2 / (1D0-R2) ) )

*  Form the matrix.
      CALL iau_IR ( RC2I )
      CALL iau_RZ ( E, RC2I )
      CALL iau_RY ( D, RC2I )
      CALL iau_RZ ( -(E+S), RC2I )

*  Finished.

*+----------------------------------------------------------------------
*
*  Copyright (C) 2020
*  Standards Of Fundamental Astronomy Board
*  of the International Astronomical Union.
*
*  =====================
*  SOFA Software License
*  =====================
*
*  NOTICE TO USER:
*
*  BY USING THIS SOFTWARE YOU ACCEPT THE FOLLOWING SIX TERMS AND
*  CONDITIONS WHICH APPLY TO ITS USE.
*
*  1. The Software is owned by the IAU SOFA Board ("SOFA").
*
*  2. Permission is granted to anyone to use the SOFA software for any
*     purpose, including commercial applications, free of charge and
*     without payment of royalties, subject to the conditions and
*     restrictions listed below.
*
*  3. You (the user) may copy and distribute SOFA source code to others,
*     and use and adapt its code and algorithms in your own software,
*     on a world-wide, royalty-free basis.  That portion of your
*     distribution that does not consist of intact and unchanged copies
*     of SOFA source code files is a "derived work" that must comply
*     with the following requirements:
*
*     a) Your work shall be marked or carry a statement that it
*        (i) uses routines and computations derived by you from
*        software provided by SOFA under license to you; and
*        (ii) does not itself constitute software provided by and/or
*        endorsed by SOFA.
*
*     b) The source code of your derived work must contain descriptions
*        of how the derived work is based upon, contains and/or differs
*        from the original SOFA software.
*
*     c) The names of all routines in your derived work shall not
*        include the prefix "iau" or "sofa" or trivial modifications
*        thereof such as changes of case.
*
*     d) The origin of the SOFA components of your derived work must
*        not be misrepresented;  you must not claim that you wrote the
*        original software, nor file a patent application for SOFA
*        software or algorithms embedded in the SOFA software.
*
*     e) These requirements must be reproduced intact in any source
*        distribution and shall apply to anyone to whom you have
*        granted a further right to modify the source code of your
*        derived work.
*
*     Note that, as originally distributed, the SOFA software is
*     intended to be a definitive implementation of the IAU standards,
*     and consequently third-party modifications are discouraged.  All
*     variations, no matter how minor, must be explicitly marked as
*     such, as explained above.
*
*  4. You shall not cause the SOFA software to be brought into
*     disrepute, either by misuse, or use for inappropriate tasks, or
*     by inappropriate modification.
*
*  5. The SOFA software is provided "as is" and SOFA makes no warranty
*     as to its use or performance.   SOFA does not and cannot warrant
*     the performance or results which the user may obtain by using the
*     SOFA software.  SOFA makes no warranties, express or implied, as
*     to non-infringement of third party rights, merchantability, or
*     fitness for any particular purpose.  In no event will SOFA be
*     liable to the user for any consequential, incidental, or special
*     damages, including any lost profits or lost savings, even if a
*     SOFA representative has been advised of such damages, or for any
*     claim by any third party.
*
*  6. The provision of any version of the SOFA software under the terms
*     and conditions specified herein does not imply that future
*     versions will also be made available under the same terms and
*     conditions.
*
*  In any published work or commercial product which uses the SOFA
*  software directly, acknowledgement (see www.iausofa.org) is
*  appreciated.
*
*  Correspondence concerning SOFA software should be addressed as
*  follows:
*
*      By email:  sofa@ukho.gov.uk
*      By post:   IAU SOFA Center
*                 HM Nautical Almanac Office
*                 UK Hydrographic Office
*                 Admiralty Way, Taunton
*                 Somerset, TA1 2DN
*                 United Kingdom
*
*-----------------------------------------------------------------------

      END


      subroutine detune(iv,ekk,ep,beta,dtu,dtup,dfac)
      implicit real*8 (a-h,o-z)
      parameter(npart=64,nmac=1)
      parameter(nele=700,nblo=300,nper=16,
     &nelb=100,nblz=20000,nzfz=300000,mmul=11)
      parameter(nran=280000,ncom=100,mran=500,mpa=6,nrco=5,nema=15)
      parameter(mcor=10)
      parameter(npos=20000,nlya=10000,ninv=1000,nplo=20000)
      parameter(nmon1=600,ncor1=600)
      parameter(pieni=1d-17)
      parameter(zero=0.0d0,half=0.5d0,one=1.0d0)
      parameter(two=2.0d0,three=3.0d0,four=4.0d0)
      dimension dfac(10),dtu(2,5),ep(2),beta(2),dtup(2,5,0:4,0:4)
      save
      pi=four*atan(one)
      iv2=2*iv
      iv3=iv+1
      vtu1=-ekk*(half**iv2)*dfac(iv2)/pi
      dtu1=zero
      dtu2=zero
      do 10 iv4=1,iv3
        iv5=iv4-1
        iv6=iv-iv5
        vor=one
        if(mod(iv6,2).ne.0) vor=-one
        vtu2=vor/(dfac(iv5+1)**2)/(dfac(iv6+1)**2)*(beta(1)**iv5)* (beta
     +  (2)**iv6)
        if(iv5.ne.0) then
          dtu1=dtu1+vtu2*iv5*(ep(1)**(iv5-1))*(ep(2)**iv6)
          dtup(1,iv,iv5-1,iv6)=dtup(1,iv,iv5-1,iv6)+vtu2*iv5*vtu1
        endif
        if(iv6.ne.0) then
          dtu2=dtu2+vtu2*iv6*(ep(1)**iv5)*(ep(2)**(iv6-1))
          dtup(2,iv,iv5,iv6-1)=dtup(2,iv,iv5,iv6-1)+vtu2*iv6*vtu1
        endif
   10 continue
      dtu(1,iv)=dtu(1,iv)+vtu1*dtu1
      dtu(2,iv)=dtu(2,iv)+vtu1*dtu2
      return
      end