MODULE icedyn_adv_umx
  USE phycst
  USE dom_oce
  USE sbc_oce, ONLY: nn_fsbc
  USE ice
  USE in_out_manager
  USE lib_mpp
  USE lib_fortran
  USE lbclnk
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: ice_dyn_adv_umx
  REAL(KIND = wp) :: z1_6 = 1._wp / 6._wp
  REAL(KIND = wp) :: z1_120 = 1._wp / 120._wp
  CONTAINS
  SUBROUTINE ice_dyn_adv_umx(k_order, kt, pu_ice, pv_ice, pato_i, pv_i, pv_s, psv_i, poa_i, pa_i, pa_ip, pv_ip, pe_s, pe_i)
    INTEGER, INTENT(IN   ) :: k_order
    INTEGER, INTENT(IN   ) :: kt
    REAL(KIND = wp), DIMENSION(:, :), INTENT(IN   ) :: pu_ice
    REAL(KIND = wp), DIMENSION(:, :), INTENT(IN   ) :: pv_ice
    REAL(KIND = wp), DIMENSION(:, :), INTENT(INOUT) :: pato_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pv_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pv_s
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: psv_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: poa_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pa_i
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pa_ip
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: pv_ip
    REAL(KIND = wp), DIMENSION(:, :, :, :), INTENT(INOUT) :: pe_s
    REAL(KIND = wp), DIMENSION(:, :, :, :), INTENT(INOUT) :: pe_i
    INTEGER :: ji, jj, jk, jl, jt
    INTEGER :: initad
    REAL(KIND = wp) :: zcfl, zusnit, zdt
    REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :) :: zudy, zvdx, zcu_box, zcv_box
    IF (kt == nit000 .AND. lwp) WRITE(numout, FMT = *) '-- ice_dyn_adv_umx: Ultimate-Macho advection scheme'
    ALLOCATE(zudy(jpi, jpj), zvdx(jpi, jpj), zcu_box(jpi, jpj), zcv_box(jpi, jpj))
    zcfl = MAXVAL(ABS(pu_ice(:, :)) * rdt_ice * r1_e1u(:, :))
    zcfl = MAX(zcfl, MAXVAL(ABS(pv_ice(:, :)) * rdt_ice * r1_e2v(:, :)))
    IF (lk_mpp) CALL mpp_max(zcfl)
    IF (zcfl > 0.5) THEN
      initad = 2
      zusnit = 0.5_wp
    ELSE
      initad = 1
      zusnit = 1.0_wp
    END IF
    !$ACC KERNELS
    zdt = rdt_ice / REAL(initad)
    zudy(:, :) = pu_ice(:, :) * e2u(:, :)
    zvdx(:, :) = pv_ice(:, :) * e1v(:, :)
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (pu_ice(ji, jj) * pu_ice(ji - 1, jj) <= 0._wp) THEN
          zcu_box(ji, jj) = 0._wp
        ELSE IF (pu_ice(ji, jj) > 0._wp) THEN
          zcu_box(ji, jj) = pu_ice(ji - 1, jj)
        ELSE
          zcu_box(ji, jj) = pu_ice(ji, jj)
        END IF
        IF (pv_ice(ji, jj) * pv_ice(ji, jj - 1) <= 0._wp) THEN
          zcv_box(ji, jj) = 0._wp
        ELSE IF (pv_ice(ji, jj) > 0._wp) THEN
          zcv_box(ji, jj) = pv_ice(ji, jj - 1)
        ELSE
          zcv_box(ji, jj) = pv_ice(ji, jj)
        END IF
      END DO
    END DO
    !$ACC END KERNELS
    DO jt = 1, initad
      CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pato_i(:, :))
      DO jl = 1, jpl
        CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pa_i(:, :, jl))
        CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_i(:, :, jl))
        CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, psv_i(:, :, jl))
        CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, poa_i(:, :, jl))
        DO jk = 1, nlay_i
          CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pe_i(:, :, jk, jl))
        END DO
        CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_s(:, :, jl))
        DO jk = 1, nlay_s
          CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pe_s(:, :, jk, jl))
        END DO
        IF (ln_pnd_H12) THEN
          CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pa_ip(:, :, jl))
          CALL adv_umx(k_order, kt, zdt, zudy, zvdx, zcu_box, zcv_box, pv_ip(:, :, jl))
        END IF
      END DO
    END DO
    DEALLOCATE(zudy, zvdx, zcu_box, zcv_box)
  END SUBROUTINE ice_dyn_adv_umx
  SUBROUTINE adv_umx(k_order, kt, pdt, puc, pvc, pubox, pvbox, ptc)
    INTEGER, INTENT(IN   ) :: k_order
    INTEGER, INTENT(IN   ) :: kt
    REAL(KIND = wp), INTENT(IN   ) :: pdt
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: puc, pvc
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pubox, pvbox
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(INOUT) :: ptc
    INTEGER :: ji, jj
    REAL(KIND = wp) :: ztra
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zfu_ups, zfu_ho, zt_u, zt_ups
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zfv_ups, zfv_ho, zt_v, ztrd
    !$ACC KERNELS
    DO jj = 1, jpjm1
      DO ji = 1, jpim1
        zfu_ups(ji, jj) = MAX(puc(ji, jj), 0._wp) * ptc(ji, jj) + MIN(puc(ji, jj), 0._wp) * ptc(ji + 1, jj)
        zfv_ups(ji, jj) = MAX(pvc(ji, jj), 0._wp) * ptc(ji, jj) + MIN(pvc(ji, jj), 0._wp) * ptc(ji, jj + 1)
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        ztra = - (zfu_ups(ji, jj) - zfu_ups(ji - 1, jj) + zfv_ups(ji, jj) - zfv_ups(ji, jj - 1)) * r1_e1e2t(ji, jj)
        ztrd(ji, jj) = ztra
        zt_ups(ji, jj) = (ptc(ji, jj) + pdt * ztra) * tmask(ji, jj, 1)
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk(zt_ups, 'T', 1.)
    SELECT CASE (k_order)
    CASE (20)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zfu_ho(ji, jj) = 0.5 * puc(ji, jj) * (ptc(ji, jj) + ptc(ji + 1, jj))
          zfv_ho(ji, jj) = 0.5 * pvc(ji, jj) * (ptc(ji, jj) + ptc(ji, jj + 1))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (1 : 5)
      CALL macho(k_order, kt, pdt, ptc, puc, pvc, pubox, pvbox, zt_u, zt_v)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 1, jpim1
          zfu_ho(ji, jj) = puc(ji, jj) * zt_u(ji, jj)
          zfv_ho(ji, jj) = pvc(ji, jj) * zt_v(ji, jj)
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
    !$ACC KERNELS
    DO jj = 1, jpjm1
      DO ji = 1, jpim1
        zfu_ho(ji, jj) = zfu_ho(ji, jj) - zfu_ups(ji, jj)
        zfv_ho(ji, jj) = zfv_ho(ji, jj) - zfv_ups(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL nonosc_2d(ptc, zfu_ho, zfv_ho, zt_ups, pdt)
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        ztra = ztrd(ji, jj) - (zfu_ho(ji, jj) - zfu_ho(ji - 1, jj) + zfv_ho(ji, jj) - zfv_ho(ji, jj - 1)) * r1_e1e2t(ji, jj)
        ptc(ji, jj) = (ptc(ji, jj) + pdt * ztra) * tmask(ji, jj, 1)
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk(ptc, 'T', 1.)
  END SUBROUTINE adv_umx
  SUBROUTINE macho(k_order, kt, pdt, ptc, puc, pvc, pubox, pvbox, pt_u, pt_v)
    INTEGER, INTENT(IN   ) :: k_order
    INTEGER, INTENT(IN   ) :: kt
    REAL(KIND = wp), INTENT(IN   ) :: pdt
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: ptc
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: puc, pvc
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pubox, pvbox
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(  OUT) :: pt_u, pt_v
    INTEGER :: ji, jj
    REAL(KIND = wp) :: zc_box
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zzt
    IF (MOD((kt - 1) / nn_fsbc, 2) == 0) THEN
      CALL ultimate_x(k_order, pdt, ptc, puc, pt_u)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zzt(ji, jj) = ptc(ji, jj) - pubox(ji, jj) * pdt * (pt_u(ji, jj) - pt_u(ji - 1, jj)) * r1_e1t(ji, jj) - ptc(ji, jj) * pdt * (puc(ji, jj) - puc(ji - 1, jj)) * r1_e1e2t(ji, jj)
          zzt(ji, jj) = zzt(ji, jj) * tmask(ji, jj, 1)
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(zzt, 'T', 1.)
      CALL ultimate_y(k_order, pdt, zzt, pvc, pt_v)
    ELSE
      CALL ultimate_y(k_order, pdt, ptc, pvc, pt_v)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zzt(ji, jj) = ptc(ji, jj) - pvbox(ji, jj) * pdt * (pt_v(ji, jj) - pt_v(ji, jj - 1)) * r1_e2t(ji, jj) - ptc(ji, jj) * pdt * (pvc(ji, jj) - pvc(ji, jj - 1)) * r1_e1e2t(ji, jj)
          zzt(ji, jj) = zzt(ji, jj) * tmask(ji, jj, 1)
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(zzt, 'T', 1.)
      CALL ultimate_x(k_order, pdt, zzt, puc, pt_u)
    END IF
  END SUBROUTINE macho
  SUBROUTINE ultimate_x(k_order, pdt, pt, puc, pt_u)
    INTEGER, INTENT(IN   ) :: k_order
    REAL(KIND = wp), INTENT(IN   ) :: pdt
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: puc
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pt
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(  OUT) :: pt_u
    INTEGER :: ji, jj
    REAL(KIND = wp) :: zcu, zdx2, zdx4
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: ztu1, ztu2, ztu3, ztu4
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 1, jpim1
        ztu1(ji, jj) = (pt(ji + 1, jj) - pt(ji, jj)) * r1_e1u(ji, jj) * umask(ji, jj, 1)
      END DO
      DO ji = 2, jpim1
        ztu2(ji, jj) = (ztu1(ji, jj) - ztu1(ji - 1, jj)) * r1_e1t(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk(ztu2, 'T', 1.)
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 1, jpim1
        ztu3(ji, jj) = (ztu2(ji + 1, jj) - ztu2(ji, jj)) * r1_e1u(ji, jj) * umask(ji, jj, 1)
      END DO
      DO ji = 2, jpim1
        ztu4(ji, jj) = (ztu3(ji, jj) - ztu3(ji - 1, jj)) * r1_e1t(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk(ztu4, 'T', 1.)
    SELECT CASE (k_order)
    CASE (1)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 1, jpim1
          pt_u(ji, jj) = 0.5_wp * umask(ji, jj, 1) * (pt(ji + 1, jj) + pt(ji, jj) - SIGN(1._wp, puc(ji, jj)) * (pt(ji + 1, jj) - pt(ji, jj)))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (2)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 1, jpim1
          zcu = puc(ji, jj) * r1_e2u(ji, jj) * pdt * r1_e1u(ji, jj)
          pt_u(ji, jj) = 0.5_wp * umask(ji, jj, 1) * (pt(ji + 1, jj) + pt(ji, jj) - zcu * (pt(ji + 1, jj) - pt(ji, jj)))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (3)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 1, jpim1
          zcu = puc(ji, jj) * r1_e2u(ji, jj) * pdt * r1_e1u(ji, jj)
          zdx2 = e1u(ji, jj) * e1u(ji, jj)
          pt_u(ji, jj) = 0.5_wp * umask(ji, jj, 1) * ((pt(ji + 1, jj) + pt(ji, jj) - zcu * (pt(ji + 1, jj) - pt(ji, jj))) + z1_6 * zdx2 * (zcu * zcu - 1._wp) * (ztu2(ji + 1, jj) + ztu2(ji, jj) - SIGN(1._wp, zcu) * (ztu2(ji + 1, jj) - ztu2(ji, jj))))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (4)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 1, jpim1
          zcu = puc(ji, jj) * r1_e2u(ji, jj) * pdt * r1_e1u(ji, jj)
          zdx2 = e1u(ji, jj) * e1u(ji, jj)
          pt_u(ji, jj) = 0.5_wp * umask(ji, jj, 1) * ((pt(ji + 1, jj) + pt(ji, jj) - zcu * (pt(ji + 1, jj) - pt(ji, jj))) + z1_6 * zdx2 * (zcu * zcu - 1._wp) * (ztu2(ji + 1, jj) + ztu2(ji, jj) - 0.5_wp * zcu * (ztu2(ji + 1, jj) - ztu2(ji, jj))))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (5)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 1, jpim1
          zcu = puc(ji, jj) * r1_e2u(ji, jj) * pdt * r1_e1u(ji, jj)
          zdx2 = e1u(ji, jj) * e1u(ji, jj)
          zdx4 = zdx2 * zdx2
          pt_u(ji, jj) = 0.5_wp * umask(ji, jj, 1) * ((pt(ji + 1, jj) + pt(ji, jj) - zcu * (pt(ji + 1, jj) - pt(ji, jj))) + z1_6 * zdx2 * (zcu * zcu - 1._wp) * (ztu2(ji + 1, jj) + ztu2(ji, jj) - 0.5_wp * zcu * (ztu2(ji + 1, jj) - ztu2(ji, jj))) + z1_120 * zdx4 * (zcu * zcu - 1._wp) * (zcu * zcu - 4._wp) * (ztu4(ji + 1, jj) + ztu4(ji, jj) - SIGN(1._wp, zcu) * (ztu4(ji + 1, jj) - ztu4(ji, jj))))
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
  END SUBROUTINE ultimate_x
  SUBROUTINE ultimate_y(k_order, pdt, pt, pvc, pt_v)
    INTEGER, INTENT(IN   ) :: k_order
    REAL(KIND = wp), INTENT(IN   ) :: pdt
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pvc
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pt
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(  OUT) :: pt_v
    INTEGER :: ji, jj
    REAL(KIND = wp) :: zcv, zdy2, zdy4
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: ztv1, ztv2, ztv3, ztv4
    !$ACC KERNELS
    DO jj = 1, jpjm1
      DO ji = 2, jpim1
        ztv1(ji, jj) = (pt(ji, jj + 1) - pt(ji, jj)) * r1_e2v(ji, jj) * vmask(ji, jj, 1)
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        ztv2(ji, jj) = (ztv1(ji, jj) - ztv1(ji, jj - 1)) * r1_e2t(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk(ztv2, 'T', 1.)
    !$ACC KERNELS
    DO jj = 1, jpjm1
      DO ji = 2, jpim1
        ztv3(ji, jj) = (ztv2(ji, jj + 1) - ztv2(ji, jj)) * r1_e2v(ji, jj) * vmask(ji, jj, 1)
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        ztv4(ji, jj) = (ztv3(ji, jj) - ztv3(ji, jj - 1)) * r1_e2t(ji, jj)
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk(ztv4, 'T', 1.)
    SELECT CASE (k_order)
    CASE (1)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 2, jpim1
          pt_v(ji, jj) = 0.5_wp * vmask(ji, jj, 1) * ((pt(ji, jj + 1) + pt(ji, jj)) - SIGN(1._wp, pvc(ji, jj)) * (pt(ji, jj + 1) - pt(ji, jj)))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (2)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 2, jpim1
          zcv = pvc(ji, jj) * r1_e1v(ji, jj) * pdt * r1_e2v(ji, jj)
          pt_v(ji, jj) = 0.5_wp * vmask(ji, jj, 1) * ((pt(ji, jj + 1) + pt(ji, jj)) - zcv * (pt(ji, jj + 1) - pt(ji, jj)))
        END DO
      END DO
      !$ACC END KERNELS
      CALL lbc_lnk(pt_v, 'V', 1.)
    CASE (3)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 2, jpim1
          zcv = pvc(ji, jj) * r1_e1v(ji, jj) * pdt * r1_e2v(ji, jj)
          zdy2 = e2v(ji, jj) * e2v(ji, jj)
          pt_v(ji, jj) = 0.5_wp * vmask(ji, jj, 1) * ((pt(ji, jj + 1) + pt(ji, jj) - zcv * (pt(ji, jj + 1) - pt(ji, jj))) + z1_6 * zdy2 * (zcv * zcv - 1._wp) * (ztv2(ji, jj + 1) + ztv2(ji, jj) - SIGN(1._wp, zcv) * (ztv2(ji, jj + 1) - ztv2(ji, jj))))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (4)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 2, jpim1
          zcv = pvc(ji, jj) * r1_e1v(ji, jj) * pdt * r1_e2v(ji, jj)
          zdy2 = e2v(ji, jj) * e2v(ji, jj)
          pt_v(ji, jj) = 0.5_wp * vmask(ji, jj, 1) * ((pt(ji, jj + 1) + pt(ji, jj) - zcv * (pt(ji, jj + 1) - pt(ji, jj))) + z1_6 * zdy2 * (zcv * zcv - 1._wp) * (ztv2(ji, jj + 1) + ztv2(ji, jj) - 0.5_wp * zcv * (ztv2(ji, jj + 1) - ztv2(ji, jj))))
        END DO
      END DO
      !$ACC END KERNELS
    CASE (5)
      !$ACC KERNELS
      DO jj = 1, jpjm1
        DO ji = 2, jpim1
          zcv = pvc(ji, jj) * r1_e1v(ji, jj) * pdt * r1_e2v(ji, jj)
          zdy2 = e2v(ji, jj) * e2v(ji, jj)
          zdy4 = zdy2 * zdy2
          pt_v(ji, jj) = 0.5_wp * vmask(ji, jj, 1) * ((pt(ji, jj + 1) + pt(ji, jj) - zcv * (pt(ji, jj + 1) - pt(ji, jj))) + z1_6 * zdy2 * (zcv * zcv - 1._wp) * (ztv2(ji, jj + 1) + ztv2(ji, jj) - 0.5_wp * zcv * (ztv2(ji, jj + 1) - ztv2(ji, jj))) + z1_120 * zdy4 * (zcv * zcv - 1._wp) * (zcv * zcv - 4._wp) * (ztv4(ji, jj + 1) + ztv4(ji, jj) - SIGN(1._wp, zcv) * (ztv4(ji, jj + 1) - ztv4(ji, jj))))
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
  END SUBROUTINE ultimate_y
  SUBROUTINE nonosc_2d(pbef, paa, pbb, paft, pdt)
    REAL(KIND = wp), INTENT(IN   ) :: pdt
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(IN   ) :: pbef, paft
    REAL(KIND = wp), DIMENSION(jpi, jpj), INTENT(INOUT) :: paa, pbb
    INTEGER :: ji, jj
    INTEGER :: ikm1
    REAL(KIND = wp) :: zpos, zneg, zbt, za, zb, zc, zbig, zsml, z1_dt
    REAL(KIND = wp) :: zau, zbu, zcu, zav, zbv, zcv, zup, zdo
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zbetup, zbetdo, zbup, zbdo, zmsk, zdiv
    !$ACC KERNELS
    zbig = 1.E+40_wp
    zsml = 1.E-15_wp
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zdiv(ji, jj) = - (paa(ji, jj) - paa(ji - 1, jj) + pbb(ji, jj) - pbb(ji, jj - 1))
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk(zdiv, 'T', 1.)
    WHERE (pbef(:, :) == 0._wp .AND. paft(:, :) == 0._wp .AND. zdiv(:, :) == 0._wp)
      zmsk(:, :) = 0._wp
    ELSEWHERE
      zmsk(:, :) = 1._wp * tmask(:, :, 1)
    END WHERE
    !$ACC KERNELS
    zbup(:, :) = MAX(pbef(:, :) * zmsk(:, :) - zbig * (1.E0 - zmsk(:, :)), paft(:, :) * zmsk(:, :) - zbig * (1.E0 - zmsk(:, :)))
    zbdo(:, :) = MIN(pbef(:, :) * zmsk(:, :) + zbig * (1.E0 - zmsk(:, :)), paft(:, :) * zmsk(:, :) + zbig * (1.E0 - zmsk(:, :)))
    z1_dt = 1._wp / pdt
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zup = MAX(zbup(ji, jj), zbup(ji - 1, jj), zbup(ji + 1, jj), zbup(ji, jj - 1), zbup(ji, jj + 1))
        zdo = MIN(zbdo(ji, jj), zbdo(ji - 1, jj), zbdo(ji + 1, jj), zbdo(ji, jj - 1), zbdo(ji, jj + 1))
        zpos = MAX(0., paa(ji - 1, jj)) - MIN(0., paa(ji, jj)) + MAX(0., pbb(ji, jj - 1)) - MIN(0., pbb(ji, jj))
        zneg = MAX(0., paa(ji, jj)) - MIN(0., paa(ji - 1, jj)) + MAX(0., pbb(ji, jj)) - MIN(0., pbb(ji, jj - 1))
        zbt = e1e2t(ji, jj) * z1_dt
        zbetup(ji, jj) = (zup - paft(ji, jj)) / (zpos + zsml) * zbt
        zbetdo(ji, jj) = (paft(ji, jj) - zdo) / (zneg + zsml) * zbt
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk_multi(zbetup, 'T', 1., zbetdo, 'T', 1.)
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 1, jpim1
        zau = MIN(1._wp, zbetdo(ji, jj), zbetup(ji + 1, jj))
        zbu = MIN(1._wp, zbetup(ji, jj), zbetdo(ji + 1, jj))
        zcu = 0.5 + SIGN(0.5, paa(ji, jj))
        paa(ji, jj) = paa(ji, jj) * (zcu * zau + (1._wp - zcu) * zbu)
      END DO
    END DO
    DO jj = 1, jpjm1
      DO ji = 2, jpim1
        zav = MIN(1._wp, zbetdo(ji, jj), zbetup(ji, jj + 1))
        zbv = MIN(1._wp, zbetup(ji, jj), zbetdo(ji, jj + 1))
        zcv = 0.5 + SIGN(0.5, pbb(ji, jj))
        pbb(ji, jj) = pbb(ji, jj) * (zcv * zav + (1._wp - zcv) * zbv)
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE nonosc_2d
END MODULE icedyn_adv_umx


      subroutine initial_values(properties,numelt)

!!!      integer, parameter :: nss    = 24
!!!      integer, parameter :: nume   = 40000
!!!      integer, parameter :: no_mat = 1000
      use  mod_parameters
      use EC_Objects_manager
      use CN_Objects_manager
      use mod_file_units

      integer :: numelt
      integer :: i, j, ig
	  common/bk00/ &
            k01,k02,k03,k04,k05,k06,k07,k08,k09,k10,k11,k12, &
            k13,k14,k15,k16,k17,k18,k19,k20,k21,k22,k23,k24, &
            k25,k26,k27,k28,k29,k30,k31,k32,k33,k34,k35,k36, &
            k37,k38,k39,k40,k41,k42,k43,k44,k45,k46,k47,k48, &
            k49,k50,k51,k52,k53,k54,k55,k56,k57,k58,k59,k60, &
            k61,k62,k63,k64,k65,k66,k67,k68,k69,k70,k71,k72, &
            k73,k74,k75,k76,k77,k78,k79,k80,k81,k82,k83,k84, &
            k85,k86,k87,k88,k89,k90,k91,k92,k93,k94,k95,k96
	  common /main_block/ a(1)
      dimension :: properties(48,*)
      common /wblock8/ abc(573,nume,4),his(573,nume,4)
      common /wblock9/ slip_n0_t(no_mat,nss,3), slip_s0_t(no_mat,nss,3)
      common /wblock10/ng,grain_mo(1000,3),bv(no_mat,87),nssmat(1000),nssimmat(1000)
      common /wblock11/ pd_counter,rhoim0(1000,nss),rhomo0(1000,nss)
      common /wblock12/ Y_modulus(nume),possion_ratio(nume),tau_y(nume)
      common /wblock20/ mat_type(nume)

      common/wblock3/  density_ms, density_ims,thermalEnthalpy(1000)
!!!!!!      common/WMLthermal/thermalflag !!!!!!,thermalconstraint(nume),Tinit(nume),Rqold(nume)
      common/WMLthermal3/thermalki(1000),thermalhi(1000), &
           thermalRoi(1000),thermalcpi(1000),thermalxi(1000),thermalDi(1000)
!!!!!      common /WMLthermal2/thermalk(nume),thermalh(nume),
!!!!!     >      thermalRo(nume),thermalcp(nume),thermalx(nume)
!!!!!     >      ,thermalD(nume)
!!!
!!!!      common/wblock3/  density_ms, density_ims,etain(1000),ecin(1000)
!!!!      common /WMLthermal/thermalflag,thermalconstraint(40000),
!!!!     1     Tinit(nume),      Tfl(nume)
!!!!      common /WMLthermal2/thermalk(nume),thermalh(nume),etae(nume)
!!!!      common /WMLthermal3/thermalki(1000),thermalhi(1000)

	  common /cleavage_plane/ cleave_n(1000,3,3)
	  common /cleavage_plane0/ cleave_n0(3,3)
	  common/hydroembrittle/critfrac(1000), sigfrac0(40000),sigfrac(40000),decfrac(40000)
	  common/hydroembrittle110/critfrac110(1000), sigfrac0110(40000)

!!!!!!      integer thermalflag
	  real cleave_n, cleave_n0, critfrac, sigfrac0, sigfrac, decfrac
	  real sigfrac0110

!      --- call this to allocate the needed arrays for CN solver
        CALL CNSetMatProp(nume,mat_type,1000,thermalki,thermalhi,thermalRoi,thermalcpi,thermalxi,thermalDi)

    do i = 1, numelt
        ig = mat_type(i)         ! assign material properties to elements
        Y_modulus(i)= properties(1,ig)
        possion_ratio(i) = properties(2,ig)
        tau_y(i) = properties(3,ig)
        sigfrac0(i)=critfrac(ig)    ! assign critical fracture stress to elements
        sigfrac0110(i)=critfrac110(ig)

!!------------------------------------------ these prop are saved in CN manager
!!!!!!!           thermalk(i)=thermalki(ig)
!!!!!!!           thermalh(i)=thermalhi(ig)
!!!!!!!           thermalRo(i)=thermalRoi(ig)
!!!!!!!           thermalcp(i)=thermalcpi(ig)
!!!!!!!           thermalx(i)=thermalxi(ig)
!!!!!!!           thermalD(i)=thermalDi(ig)
!!------------------------------------------ these prop are saved in CN manager

        do j = 1, 20
            abc(397+j,i,1) = 0.0
        end do

        abc(362,i,1) = 0.0

        do j = 1, 3
            abc(362+j,i,1) = cleave_n(ig,1,j)
            abc(365+j,i,1) = cleave_n(ig,2,j)
            abc(368+j,i,1) = cleave_n(ig,3,j)
        end do

        do j = 1, nssmat(ig)
         j1=57+j
          abc(j1,i,1)= rhomo0(ig,j)
         j2=81+j
          abc(j2,i,1)= rhoim0(ig,j)
         j3=105+j
          abc(j3,i,1)=slip_n0_t(ig,j,1)
         j4=129+j
          abc(j4,i,1)=slip_n0_t(ig,j,2)
         j5 = 153 + j
          abc(j5,i,1) = slip_n0_t(ig,j,3)
         j6=177 + j
          abc(j6,i,1)=slip_s0_t(ig,j,1)
         j7=201+j
          abc(j7,i,1)=slip_s0_t(ig,j,2)
         j8=225+j
          abc(j8,i,1)=slip_s0_t(ig,j,3)
          j9 = 337+j
          abc(j9,i,1) = 0.0
        end do
    end do
!!!---------  for debugging
!!    write(iFU_check_transform_out,*) '---- elements cleavage planes before GB and crack.in   '
!!    do i = 1, numelt
!!        write(iFU_check_transform_out,*) '---- ele id= ',i
!!        do j = 1, 3
!!            write(iFU_check_transform_out,*)abc(362+j,i,1),abc(365+j,i,1),abc(368+j,i,1)
!!        end do
!!    end do
!!!---------  for debugging

! #####################################################
! #####################################################
!! -- call the GB functions to apply any GB cleave planes to the elements
!! -- this is has to be done after applying the cleave for all elements
      call GBApplyCleavagePlanes()
! #####################################################
! #####################################################
!!      this is has to be called first b/c the pre-crack needs it
!       call FractReadElemNeighbors()
!      to read precracked elements and apply proper cleavage planes
       call FractReadApplyPreCrackCleavagePlanes(a(k03),a(k04),a(k02),a(k08),a(k57),a(k18),a(k20), a(k07), a(k09))
                                              !!(y     ,z     ,ix    , matp , id   , u    , usi  , freep , ym)

!!!       call EC_PrintTest()

! #####################################################
! #####################################################
!!!!---------  for debugging
!!!    write(iFU_check_transform_out,*) '---- elements cleavage planes after GB and crack.in   '
!!!    do i = 1, numelt
!!!        write(iFU_check_transform_out,*) '---- ele id= ',i
!!!        do j = 1, 3
!!!            write(iFU_check_transform_out,*)abc(362+j,i,1),abc(365+j,i,1),abc(368+j,i,1)
!!!        end do
!!!    end do
!!!!---------  for debugging

!!!!           write(*,*)Y_modulus(1:numelt)
!!!!           write(*,*)possion_ratio(1:numelt)
!!!!           write(*,*)tau_y(1:numelt)
!!!!           write(*,*)thermalk(1:numelt)
!!!!           write(*,*)thermalh(1:numelt)
!!!!           write(*,*)thermalRo(1:numelt)
!!!!           write(*,*)thermalcp(1:numelt)
!!!!           write(*,*)thermalKa(1:numelt)

	  !write(*,*) 'in initial_values' !WMLWRITE51210
	  !write(*,*) nssmat(1)           !WMLWRITE51210

    close(iFU_check_transform_out)
    write(*, *) '-->>>>>>>>initial_values --done'
!!    stop
end


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
c>
c> \brief regularization function for tangential contact mortar (old, only for contactstress2)
c>
c> @param [in]	lambdatt	lambdatilde_tau=lambda_tau-bar{lambda}_tau
c> @param [in]	divmode 	indicates whether funtion or derivate
c>                             	should be called
c>                    		=0 function called
c>                    		=1 derivative called
c> @param [in]	regmode        	selects regularization funtion
c>                    		=1 perturbed Lagrange
c> @param [out] gtc	        result regularization function
c> @param [in]  atauinvloc      stiffness constant for perturbed Lagrange
c> @param [in] 	p0		parameter for exponential regularization
c> @param [in] 	beta		parameter for exponential regularization
c> @param [in] 	elcon		material parameters
c> @param [in] 	nelcon		(1,i) number of elastic constants for material i (2,i) number of temperature points
c> @param [in] 	itie		current tie
c> @param [in] 	ntmat_		 maximum number of temperature data points for any material
c> @param [in] 	plicon		isotropic hardening curve or points for pressure-overclosure=tabular
c> @param [in] 	nplicon		isotropic hardening curve.
c> @param [in] 	npmat_		maximum number of data points for plicon
c> @param [in] 	ncmat_		maximum number of elastic material constants
c> @param [in] 	tietol		(1,i) tie tolerance (2,i) contant interaction material definition
c>
      subroutine regularization_gt_c(lambdatt,divmode,regmode,
     &     gtc,atauinvloc,p0,beta,elcon,nelcon,itie,ntmat_,
     &     plicon,nplicon,npmat_,ncmat_,tietol)
!
!     regularization function for tangential contact
!     Author: Saskia Sitzmann
!
      implicit none
!
      integer divmode,regmode,i,ndata,kode,npmat_,ncmat_,
     &     itie,ntmat_,nplicon(0:ntmat_,*),nelcon(2,*),
     &     imat
!
!
      real*8 lambdatt(*),gtc(*),pn_d(40),gn_d(40),aninv1(40),t(40),
     &     beta,p0,atauinvloc,elconloc(21),plconloc(82),t1l,
     &     elcon(0:ncmat_,ntmat_,*),plicon(0:2*npmat_,ntmat_,*),
     &     tietol(2,*)

      kode=-51
      t1l=0.0
c     imat=int(tietol(2,itie+1))

!
!     perturbed Lagrange
!
      if(regmode.eq.1)then
         if(divmode.eq.0)then
            gtc(1)=atauinvloc*lambdatt(1)
            gtc(2)=atauinvloc*lambdatt(2)
         elseif(divmode.eq.1)then
            gtc(1)=atauinvloc
            gtc(2)=atauinvloc
         else
            write(*,*)'error in regularzation_gt_c.f!'
            call exit(201)
         endif
      else
         gtc(1)=0.0
         gtc(2)=0.0
      endif

      return
      end


c
c
c     ###############################################################
c     ##  COPYRIGHT (C) 2006 by David Gohara & Jay William Ponder  ##
c     ##                    All Rights Reserved                    ##
c     ###############################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine nblist  --  maintain pairwise neighbor lists  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "nblist" constructs and maintains nonbonded pair neighbor lists
c     for vdw and electrostatic interactions
c
c
      subroutine nblist
      implicit none
      include 'cutoff.i'
      include 'potent.i'
c
c
c     update the vdw and electrostatic neighbor lists
c
      if (use_vdw .and. use_vlist)  call vlist
      if (use_charge .and. use_clist)  call clist
      if ((use_mpole.or.use_polar) .and. use_mlist)  call mlist
      if (use_polar .and. use_ulist)  call ulist
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine vlist  --  build van der Waals neighbor lists  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "vlist" performs an update or a complete rebuild of the
c     van der Waals neighbor list
c
c
      subroutine vlist
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'iounit.i'
      include 'neigh.i'
      include 'vdw.i'
      integer i,j,k
      integer ii,iv
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius
      real*8 rdn,r2
      real*8, allocatable :: xred(:)
      real*8, allocatable :: yred(:)
      real*8, allocatable :: zred(:)
c
c
c     perform dynamic allocation of some local arrays
c
      allocate (xred(n))
      allocate (yred(n))
      allocate (zred(n))
c
c     apply reduction factors to find coordinates for each site
c
      do i = 1, nvdw
         ii = ivdw(i)
         iv = ired(ii)
         rdn = kred(ii)
         xred(i) = rdn*(x(ii)-x(iv)) + x(iv)
         yred(i) = rdn*(y(ii)-y(iv)) + y(iv)
         zred(i) = rdn*(z(ii)-z(iv)) + z(iv)
      end do
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(vbuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' VLIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (dovlst) then
         dovlst = .false.
         if (octahedron) then
            do i = 1, nvdw
               call vbuild (i,xred,yred,zred)
            end do
         else
            call vlight (xred,yred,zred)
         end if
         return
      end if
c
c     test each site for displacement exceeding half the buffer
c
      do i = 1, nvdw
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         xr = xi - xvold(i)
         yr = yi - yvold(i)
         zr = zi - zvold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
c
c     store coordinates to reflect update of this site
c
         if (r2 .ge. lbuf2) then
            xvold(i) = xi
            yvold(i) = yi
            zvold(i) = zi
c
c     rebuild the higher numbered neighbors of this site
c
            j = 0
            do k = i+1, nvdw
               xr = xi - xvold(k)
               yr = yi - yvold(k)
               zr = zi - zvold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. vbuf2) then
                  j = j + 1
                  vlst(j,i) = k
               end if
            end do
            nvlst(i) = j
c
c     check to see if the neighbor list is too long
c
            if (nvlst(i) .ge. maxvlst) then
               write (iout,20)
   20          format (/,' VLIST  --  Too many Neighbors;',
     &                    ' Increase MAXVLST')
               call fatal
            end if
c
c     adjust lists of lower numbered neighbors of this site
c
            do k = 1, i-1
               xr = xi - xvold(k)
               yr = yi - yvold(k)
               zr = zi - zvold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. vbuf2) then
                  do j = 1, nvlst(k)
                     if (vlst(j,k) .eq. i)  goto 30
                  end do
                  nvlst(k) = nvlst(k) + 1
                  vlst(nvlst(k),k) = i
   30             continue
               else if (r2 .le. vbufx) then
                  do j = 1, nvlst(k)
                     if (vlst(j,k) .eq. i) then
                        vlst(j,k) = vlst(nvlst(k),k)
                        nvlst(k) = nvlst(k) - 1
                        goto 40
                     end if
                  end do
   40             continue
               end if
            end do
         end if
      end do
c
c     perform deallocation of some local arrays
c
      deallocate (xred)
      deallocate (yred)
      deallocate (zred)
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine vbuild  --  make vdw pair list for one site  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "vbuild" performs a complete rebuild of the van der Waals
c     pair neighbor list for a single site
c
c
      subroutine vbuild (i,xred,yred,zred)
      implicit none
      include 'sizes.i'
      include 'bound.i'
      include 'iounit.i'
      include 'neigh.i'
      include 'vdw.i'
      integer i,j,k
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
      real*8 xred(*)
      real*8 yred(*)
      real*8 zred(*)
c
c
c     store coordinates to reflect update of the site
c
      xi = xred(i)
      yi = yred(i)
      zi = zred(i)
      xvold(i) = xi
      yvold(i) = yi
      zvold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
      j = 0
      do k = i+1, nvdw
         xr = xi - xred(k)
         yr = yi - yred(k)
         zr = zi - zred(k)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         if (r2 .le. vbuf2) then
            j = j + 1
            vlst(j,i) = k
         end if
      end do
      nvlst(i) = j
c
c     check to see if the neighbor list is too long
c
      if (nvlst(i) .ge. maxvlst) then
         write (iout,10)
   10    format (/,' VBUILD  --  Too many Neighbors;',
     &              ' Increase MAXVLST')
         call fatal
      end if
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine vlight  --  make vdw pair list for all sites  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "vlight" performs a complete rebuild of the van der Waals
c     pair neighbor list for all sites using the method of lights
c
c
      subroutine vlight (xred,yred,zred)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'iounit.i'
      include 'light.i'
      include 'neigh.i'
      include 'vdw.i'
      integer i,j,k
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8 xred(*)
      real*8 yred(*)
      real*8 zred(*)
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical repeat
c
c
c     perform dynamic allocation of some local arrays
c
      nlight = (ncell+1) * nvdw
      allocate (xsort(nlight))
      allocate (ysort(nlight))
      allocate (zsort(nlight))
c
c     transfer interaction site coordinates to sorting arrays
c
      do i = 1, nvdw
         nvlst(i) = 0
         xvold(i) = xred(i)
         yvold(i) = yred(i)
         zvold(i) = zred(i)
         xsort(i) = xred(i)
         ysort(i) = yred(i)
         zsort(i) = zred(i)
      end do
c
c     use the method of lights to generate neighbors
c
      off = sqrt(vbuf2)
      call lights (off,nvdw,xsort,ysort,zsort)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     loop over all atoms computing the neighbor lists
c
      do i = 1, nvdw
         xi = xred(i)
         yi = yred(i)
         zi = zred(i)
         if (kbx(i) .le. kex(i)) then
            repeat = .false.
            start = kbx(i) + 1
            stop = kex(i)
         else
            repeat = .true.
            start = 1
            stop = kex(i)
         end if
   10    continue
         do j = start, stop
            k = locx(j)
            kgy = rgy(k)
            if (kby(i) .le. key(i)) then
               if (kgy.lt.kby(i) .or. kgy.gt.key(i))  goto 20
            else
               if (kgy.lt.kby(i) .and. kgy.gt.key(i))  goto 20
            end if
            kgz = rgz(k)
            if (kbz(i) .le. kez(i)) then
               if (kgz.lt.kbz(i) .or. kgz.gt.kez(i))  goto 20
            else
               if (kgz.lt.kbz(i) .and. kgz.gt.kez(i))  goto 20
            end if
            xr = xi - xred(k)
            yr = yi - yred(k)
            zr = zi - zred(k)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. vbuf2) then
               if (i .lt. k) then
                  nvlst(i) = nvlst(i) + 1
                  vlst(nvlst(i),i) = k
               else
                  nvlst(k) = nvlst(k) + 1
                  vlst(nvlst(k),k) = i
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(i) + 1
            stop = nlight
            goto 10
         end if
      end do
c
c     check to see if the neighbor lists are too long
c
      do i = 1, nvdw
         if (nvlst(i) .ge. maxvlst) then
            write (iout,30)
   30       format (/,' VFULL  --  Too many Neighbors;',
     &                 ' Increase MAXVLST')
            call fatal
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine clist  --  build partial charge neighbor lists  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "clist" performs an update or a complete rebuild of the
c     electrostatic neighbor lists for partial charges
c
c
      subroutine clist
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'charge.i'
      include 'iounit.i'
      include 'neigh.i'
      integer i,j,k,ii
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius,r2
c
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(cbuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' CLIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (doclst) then
         doclst = .false.
         if (octahedron) then
            do i = 1, nion
               call cbuild (i)
            end do
         else
            call clight
         end if
         return
      end if
c
c     test each site for displacement exceeding half the buffer
c
      do i = 1, nion
         ii = kion(i)
         xi = x(ii)
         yi = y(ii)
         zi = z(ii)
         xr = xi - xcold(i)
         yr = yi - ycold(i)
         zr = zi - zcold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
c
c     store coordinates to reflect update of this site
c
         if (r2 .ge. lbuf2) then
            xcold(i) = xi
            ycold(i) = yi
            zcold(i) = zi
c
c     rebuild the higher numbered neighbors of this site
c
            j = 0
            do k = i+1, nion
               xr = xi - xcold(k)
               yr = yi - ycold(k)
               zr = zi - zcold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. cbuf2) then
                  j = j + 1
                  elst(j,i) = k
               end if
            end do
            nelst(i) = j
c
c     check to see if the neighbor list is too long
c
            if (nelst(i) .ge. maxelst) then
               write (iout,20)
   20          format (/,' CLIST  --  Too many Neighbors;',
     &                    ' Increase MAXELST')
               call fatal
            end if
c
c     adjust lists of lower numbered neighbors of this site
c
            do k = 1, i-1
               xr = xi - xcold(k)
               yr = yi - ycold(k)
               zr = zi - zcold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. cbuf2) then
                  do j = 1, nelst(k)
                     if (elst(j,k) .eq. i)  goto 30
                  end do
                  nelst(k) = nelst(k) + 1
                  elst(nelst(k),k) = i
   30             continue
               else if (r2 .le. cbufx) then
                  do j = 1, nelst(k)
                     if (elst(j,k) .eq. i) then
                        elst(j,k) = elst(nelst(k),k)
                        nelst(k) = nelst(k) - 1
                        goto 40
                     end if
                  end do
   40             continue
               end if
            end do
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine cbuild  --  make charge pair list for one site  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "cbuild" performs a complete rebuild of the partial charge
c     electrostatic neighbor list for a single site
c
c
      subroutine cbuild (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'charge.i'
      include 'iounit.i'
      include 'neigh.i'
      integer i,j,k,ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     store new coordinates to reflect update of the site
c
      ii = kion(i)
      xi = x(ii)
      yi = y(ii)
      zi = z(ii)
      xcold(i) = xi
      ycold(i) = yi
      zcold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
      j = 0
      do k = i+1, nion
         kk = kion(k)
         xr = xi - x(kk)
         yr = yi - y(kk)
         zr = zi - z(kk)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         if (r2 .le. cbuf2) then
            j = j + 1
            elst(j,i) = k
         end if
      end do
      nelst(i) = j
c
c     check to see if the neighbor list is too long
c
      if (nelst(i) .ge. maxelst) then
         write (iout,10)
   10    format (/,' CBUILD  --  Too many Neighbors;',
     &              ' Increase MAXELST')
         call fatal
      end if
      return
      end
c
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine clight  --  make charge pair list for all sites  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "clight" performs a complete rebuild of the partial charge
c     pair neighbor list for all sites using the method of lights
c
c
      subroutine clight
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'charge.i'
      include 'iounit.i'
      include 'light.i'
      include 'neigh.i'
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical repeat
c
c
c     perform dynamic allocation of some local arrays
c
      nlight = (ncell+1) * nion
      allocate (xsort(nlight))
      allocate (ysort(nlight))
      allocate (zsort(nlight))
c
c     transfer interaction site coordinates to sorting arrays
c
      do i = 1, nion
         nelst(i) = 0
         ii = kion(i)
         xcold(i) = x(ii)
         ycold(i) = y(ii)
         zcold(i) = z(ii)
         xsort(i) = x(ii)
         ysort(i) = y(ii)
         zsort(i) = z(ii)
      end do
c
c     use the method of lights to generate neighbors
c
      off = sqrt(cbuf2)
      call lights (off,nion,xsort,ysort,zsort)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     loop over all atoms computing the neighbor lists
c
      do i = 1, nion
         ii = kion(i)
         xi = x(ii)
         yi = y(ii)
         zi = z(ii)
         if (kbx(i) .le. kex(i)) then
            repeat = .false.
            start = kbx(i) + 1
            stop = kex(i)
         else
            repeat = .true.
            start = 1
            stop = kex(i)
         end if
   10    continue
         do j = start, stop
            k = locx(j)
            kk = kion(k)
            kgy = rgy(k)
            if (kby(i) .le. key(i)) then
               if (kgy.lt.kby(i) .or. kgy.gt.key(i))  goto 20
            else
               if (kgy.lt.kby(i) .and. kgy.gt.key(i))  goto 20
            end if
            kgz = rgz(k)
            if (kbz(i) .le. kez(i)) then
               if (kgz.lt.kbz(i) .or. kgz.gt.kez(i))  goto 20
            else
               if (kgz.lt.kbz(i) .and. kgz.gt.kez(i))  goto 20
            end if
            xr = xi - x(kk)
            yr = yi - y(kk)
            zr = zi - z(kk)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. cbuf2) then
               if (i .lt. k) then
                  nelst(i) = nelst(i) + 1
                  elst(nelst(i),i) = k
               else
                  nelst(k) = nelst(k) + 1
                  elst(nelst(k),k) = i
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(i) + 1
            stop = nlight
            goto 10
         end if
      end do
c
c     check to see if the neighbor lists are too long
c
      do i = 1, nion
         if (nelst(i) .ge. maxelst) then
            write (iout,30)
   30       format (/,' CFULL  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine mlist  --  build atom multipole neighbor lists  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mlist" performs an update or a complete rebuild of the
c     electrostatic neighbor lists for atomic multipoles
c
c
      subroutine mlist
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'neigh.i'
      integer i,j,k,ii
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius,r2
c
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(mbuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' MLIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (domlst) then
         domlst = .false.
         if (octahedron) then
            do i = 1, npole
               call mbuild (i)
            end do
         else
            call mlight
         end if
         return
      end if
c
c     test each site for displacement exceeding half the buffer
c
      do i = 1, npole
         ii = ipole(i)
         xi = x(ii)
         yi = y(ii)
         zi = z(ii)
         xr = xi - xmold(i)
         yr = yi - ymold(i)
         zr = zi - zmold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
c
c     store coordinates to reflect update of this site
c
         if (r2 .ge. lbuf2) then
            xmold(i) = xi
            ymold(i) = yi
            zmold(i) = zi
c
c     rebuild the higher numbered neighbors of this site
c
            j = 0
            do k = i+1, npole
               xr = xi - xmold(k)
               yr = yi - ymold(k)
               zr = zi - zmold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. mbuf2) then
                  j = j + 1
                  elst(j,i) = k
               end if
            end do
            nelst(i) = j
c
c     check to see if the neighbor list is too long
c
            if (nelst(i) .ge. maxelst) then
               write (iout,20)
   20          format (/,' MLIST  --  Too many Neighbors;',
     &                    ' Increase MAXELST')
               call fatal
            end if
c
c     adjust lists of lower numbered neighbors of this site
c
            do k = 1, i-1
               xr = xi - xmold(k)
               yr = yi - ymold(k)
               zr = zi - zmold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. mbuf2) then
                  do j = 1, nelst(k)
                     if (elst(j,k) .eq. i)  goto 30
                  end do
                  nelst(k) = nelst(k) + 1
                  elst(nelst(k),k) = i
   30             continue
               else if (r2 .le. mbufx) then
                  do j = 1, nelst(k)
                     if (elst(j,k) .eq. i) then
                        elst(j,k) = elst(nelst(k),k)
                        nelst(k) = nelst(k) - 1
                        goto 40
                     end if
                  end do
   40             continue
               end if
            end do
         end if
      end do
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine mbuild  --  make mpole pair list for one site  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "mbuild" performs a complete rebuild of the atomic multipole
c     electrostatic neighbor list for a single site
c
c
      subroutine mbuild (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'neigh.i'
      integer i,j,k,ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     store new coordinates to reflect update of the site
c
      ii = ipole(i)
      xi = x(ii)
      yi = y(ii)
      zi = z(ii)
      xmold(i) = xi
      ymold(i) = yi
      zmold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
      j = 0
      do k = i+1, npole
         kk = ipole(k)
         xr = xi - x(kk)
         yr = yi - y(kk)
         zr = zi - z(kk)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         if (r2 .le. mbuf2) then
            j = j + 1
            elst(j,i) = k
         end if
      end do
      nelst(i) = j
c
c     check to see if the neighbor list is too long
c
      if (nelst(i) .ge. maxelst) then
         write (iout,10)
   10    format (/,' MBUILD  --  Too many Neighbors;',
     &              ' Increase MAXELST')
         call fatal
      end if
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine mlight  --  make mpole pair list for all sites  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "mlight" performs a complete rebuild of the atomic multipole
c     pair neighbor list for all sites using the method of lights
c
c
      subroutine mlight
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'iounit.i'
      include 'light.i'
      include 'mpole.i'
      include 'neigh.i'
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical repeat
c
c
c     perform dynamic allocation of some local arrays
c
      nlight = (ncell+1) * npole
      allocate (xsort(nlight))
      allocate (ysort(nlight))
      allocate (zsort(nlight))
c
c     transfer interaction site coordinates to sorting arrays
c
      do i = 1, npole
         nelst(i) = 0
         ii = ipole(i)
         xmold(i) = x(ii)
         ymold(i) = y(ii)
         zmold(i) = z(ii)
         xsort(i) = x(ii)
         ysort(i) = y(ii)
         zsort(i) = z(ii)
      end do
c
c     use the method of lights to generate neighbors
c
      off = sqrt(mbuf2)
      call lights (off,npole,xsort,ysort,zsort)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     loop over all atoms computing the neighbor lists
c
      do i = 1, npole
         ii = ipole(i)
         xi = x(ii)
         yi = y(ii)
         zi = z(ii)
         if (kbx(i) .le. kex(i)) then
            repeat = .false.
            start = kbx(i) + 1
            stop = kex(i)
         else
            repeat = .true.
            start = 1
            stop = kex(i)
         end if
   10    continue
         do j = start, stop
            k = locx(j)
            kk = ipole(k)
            kgy = rgy(k)
            if (kby(i) .le. key(i)) then
               if (kgy.lt.kby(i) .or. kgy.gt.key(i))  goto 20
            else
               if (kgy.lt.kby(i) .and. kgy.gt.key(i))  goto 20
            end if
            kgz = rgz(k)
            if (kbz(i) .le. kez(i)) then
               if (kgz.lt.kbz(i) .or. kgz.gt.kez(i))  goto 20
            else
               if (kgz.lt.kbz(i) .and. kgz.gt.kez(i))  goto 20
            end if
            xr = xi - x(kk)
            yr = yi - y(kk)
            zr = zi - z(kk)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. mbuf2) then
               if (i .lt. k) then
                  nelst(i) = nelst(i) + 1
                  elst(nelst(i),i) = k
               else
                  nelst(k) = nelst(k) + 1
                  elst(nelst(k),k) = i
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(i) + 1
            stop = nlight
            goto 10
         end if
      end do
c
c     check to see if the neighbor lists are too long
c
      do i = 1, npole
         if (nelst(i) .ge. maxelst) then
            write (iout,30)
   30       format (/,' MFULL  --  Too many Neighbors;',
     &                 ' Increase MAXELST')
            call fatal
         end if
      end do
      return
      end
c
c
c     #################################################################
c     ##                                                             ##
c     ##  subroutine ulist  --  build preconditioner neighbor lists  ##
c     ##                                                             ##
c     #################################################################
c
c
c     "ulist" performs an update or a complete rebuild of the
c     neighbor lists for the polarization preconditioner
c
c
      subroutine ulist
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'boxes.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'neigh.i'
      integer i,j,k,ii
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 radius,r2
c
c
c     neighbor list cannot be used with the replicates method
c
      radius = sqrt(ubuf2)
      call replica (radius)
      if (use_replica) then
         write (iout,10)
   10    format (/,' ULIST  --  Pairwise Neighbor List cannot',
     &              ' be used with Replicas')
         call fatal
      end if
c
c     perform a complete list build instead of an update
c
      if (doulst) then
         doulst = .false.
         if (octahedron) then
            do i = 1, npole
               call ubuild (i)
            end do
         else
            call ulight
         end if
         return
      end if
c
c     test each site for displacement exceeding half the buffer
c
      do i = 1, npole
         ii = ipole(i)
         xi = x(ii)
         yi = y(ii)
         zi = z(ii)
         xr = xi - xuold(i)
         yr = yi - yuold(i)
         zr = zi - zuold(i)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
c
c     store coordinates to reflect update of this site
c
         if (r2 .ge. pbuf2) then
            xuold(i) = xi
            yuold(i) = yi
            zuold(i) = zi
c
c     rebuild the higher numbered neighbors of this site
c
            j = 0
            do k = i+1, npole
               xr = xi - xuold(k)
               yr = yi - yuold(k)
               zr = zi - zuold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. ubuf2) then
                  j = j + 1
                  ulst(j,i) = k
               end if
            end do
            nulst(i) = j
c
c     check to see if the neighbor list is too long
c
            if (nulst(i) .ge. maxulst) then
               write (iout,20)
   20          format (/,' ULIST  --  Too many Neighbors;',
     &                    ' Increase MAXULST')
               call fatal
            end if
c
c     adjust lists of lower numbered neighbors of this site
c
            do k = 1, i-1
               xr = xi - xuold(k)
               yr = yi - yuold(k)
               zr = zi - zuold(k)
               call imagen (xr,yr,zr)
               r2 = xr*xr + yr*yr + zr*zr
               if (r2 .le. ubuf2) then
                  do j = 1, nulst(k)
                     if (ulst(j,k) .eq. i)  goto 30
                  end do
                  nulst(k) = nulst(k) + 1
                  ulst(nulst(k),k) = i
   30             continue
               else if (r2 .le. ubufx) then
                  do j = 1, nulst(k)
                     if (ulst(j,k) .eq. i) then
                        ulst(j,k) = ulst(nulst(k),k)
                        nulst(k) = nulst(k) - 1
                        goto 40
                     end if
                  end do
   40             continue
               end if
            end do
         end if
      end do
      return
      end
c
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine ubuild  --  preconditioner list for one site  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "ubuild" performs a complete rebuild of the polarization
c     preconditioner neighbor list for a single site
c
c
      subroutine ubuild (i)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'iounit.i'
      include 'mpole.i'
      include 'neigh.i'
      integer i,j,k,ii,kk
      real*8 xi,yi,zi
      real*8 xr,yr,zr,r2
c
c
c     store new coordinates to reflect update of the site
c
      ii = ipole(i)
      xi = x(ii)
      yi = y(ii)
      zi = z(ii)
      xuold(i) = xi
      yuold(i) = yi
      zuold(i) = zi
c
c     generate all neighbors for the site being rebuilt
c
      j = 0
      do k = i+1, npole
         kk = ipole(k)
         xr = xi - x(kk)
         yr = yi - y(kk)
         zr = zi - z(kk)
         call imagen (xr,yr,zr)
         r2 = xr*xr + yr*yr + zr*zr
         if (r2 .le. ubuf2) then
            j = j + 1
            ulst(j,i) = k
         end if
      end do
      nulst(i) = j
c
c     check to see if the neighbor list is too long
c
      if (nulst(i) .ge. maxulst) then
         write (iout,10)
   10    format (/,' UBUILD  --  Too many Neighbors;',
     &              ' Increase MAXULST')
         call fatal
      end if
      return
      end
c
c
c     ################################################################
c     ##                                                            ##
c     ##  subroutine ulight  --  preconditioner list for all sites  ##
c     ##                                                            ##
c     ################################################################
c
c
c     "ulight" performs a complete rebuild of the polarization
c     preconditioner pair neighbor list for all sites using the
c     method of lights
c
c
      subroutine ulight
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cell.i'
      include 'iounit.i'
      include 'light.i'
      include 'mpole.i'
      include 'neigh.i'
      integer i,j,k
      integer ii,kk
      integer kgy,kgz
      integer start,stop
      real*8 xi,yi,zi
      real*8 xr,yr,zr
      real*8 r2,off
      real*8, allocatable :: xsort(:)
      real*8, allocatable :: ysort(:)
      real*8, allocatable :: zsort(:)
      logical repeat
c
c
c     perform dynamic allocation of some local arrays
c
      nlight = (ncell+1) * npole
      allocate (xsort(nlight))
      allocate (ysort(nlight))
      allocate (zsort(nlight))
c
c     transfer interaction site coordinates to sorting arrays
c
      do i = 1, npole
         nulst(i) = 0
         ii = ipole(i)
         xuold(i) = x(ii)
         yuold(i) = y(ii)
         zuold(i) = z(ii)
         xsort(i) = x(ii)
         ysort(i) = y(ii)
         zsort(i) = z(ii)
      end do
c
c     use the method of lights to generate neighbors
c
      off = sqrt(ubuf2)
      call lights (off,npole,xsort,ysort,zsort)
c
c     perform deallocation of some local arrays
c
      deallocate (xsort)
      deallocate (ysort)
      deallocate (zsort)
c
c     loop over all atoms computing the neighbor lists
c
      do i = 1, npole
         ii = ipole(i)
         xi = x(ii)
         yi = y(ii)
         zi = z(ii)
         if (kbx(i) .le. kex(i)) then
            repeat = .false.
            start = kbx(i) + 1
            stop = kex(i)
         else
            repeat = .true.
            start = 1
            stop = kex(i)
         end if
   10    continue
         do j = start, stop
            k = locx(j)
            kk = ipole(k)
            kgy = rgy(k)
            if (kby(i) .le. key(i)) then
               if (kgy.lt.kby(i) .or. kgy.gt.key(i))  goto 20
            else
               if (kgy.lt.kby(i) .and. kgy.gt.key(i))  goto 20
            end if
            kgz = rgz(k)
            if (kbz(i) .le. kez(i)) then
               if (kgz.lt.kbz(i) .or. kgz.gt.kez(i))  goto 20
            else
               if (kgz.lt.kbz(i) .and. kgz.gt.kez(i))  goto 20
            end if
            xr = xi - x(kk)
            yr = yi - y(kk)
            zr = zi - z(kk)
            call imagen (xr,yr,zr)
            r2 = xr*xr + yr*yr + zr*zr
            if (r2 .le. ubuf2) then
               if (i .lt. k) then
                  nulst(i) = nulst(i) + 1
                  ulst(nulst(i),i) = k
               else
                  nulst(k) = nulst(k) + 1
                  ulst(nulst(k),k) = i
               end if
            end if
   20       continue
         end do
         if (repeat) then
            repeat = .false.
            start = kbx(i) + 1
            stop = nlight
            goto 10
         end if
      end do
c
c     check to see if the neighbor lists are too long
c
      do i = 1, npole
         if (nulst(i) .ge. maxulst) then
            write (iout,30)
   30       format (/,' UFULL  --  Too many Neighbors;',
     &                 ' Increase MAXULST')
            call fatal
         end if
      end do
      return
      end
c
c
c     ##############################################################
c     ##                                                          ##
c     ##  subroutine imagen  --  neighbor minimum image distance  ##
c     ##                                                          ##
c     ##############################################################
c
c
c     "imagen" takes the components of pairwise distance between
c     two points and converts to the components of the minimum
c     image distance; fast version for neighbor list generation
c     which only returns the correct component magnitudes
c
c
      subroutine imagen (xr,yr,zr)
      implicit none
      include 'boxes.i'
      real*8 xr,yr,zr
c
c
c     for orthogonal lattice, find the desired image directly
c
      if (orthogonal) then
         xr = abs(xr)
         yr = abs(yr)
         zr = abs(zr)
         if (xr .gt. xbox2)  xr = xr - xbox
         if (yr .gt. ybox2)  yr = yr - ybox
         if (zr .gt. zbox2)  zr = zr - zbox
c
c     for monoclinic lattice, convert "xr" and "zr" specially
c
      else if (monoclinic) then
         zr = zr / beta_sin
         yr = abs(yr)
         xr = xr - zr*beta_cos
         if (abs(xr) .gt. xbox2)  xr = xr - sign(xbox,xr)
         if (yr .gt. ybox2)  yr = yr - ybox
         if (abs(zr) .gt. zbox2)  zr = zr - sign(zbox,zr)
         xr = xr + zr*beta_cos
         zr = zr * beta_sin
c
c     for triclinic lattice, use general conversion equations
c
      else if (triclinic) then
         zr = zr / gamma_term
         yr = (yr - zr*beta_term) / gamma_sin
         xr = xr - yr*gamma_cos - zr*beta_cos
         if (abs(xr) .gt. xbox2)  xr = xr - sign(xbox,xr)
         if (abs(yr) .gt. ybox2)  yr = yr - sign(ybox,yr)
         if (abs(zr) .gt. zbox2)  zr = zr - sign(zbox,zr)
         xr = xr + yr*gamma_cos + zr*beta_cos
         yr = yr*gamma_sin + zr*beta_term
         zr = zr * gamma_term
c
c     for truncated octahedron, remove the corner pieces
c
      else if (octahedron) then
         if (abs(xr) .gt. xbox2)  xr = xr - sign(xbox,xr)
         if (abs(yr) .gt. ybox2)  yr = yr - sign(ybox,yr)
         if (abs(zr) .gt. zbox2)  zr = zr - sign(zbox,zr)
         if (abs(xr)+abs(yr)+abs(zr) .gt. box34) then
            xr = xr - sign(xbox2,xr)
            yr = yr - sign(ybox2,yr)
            zr = zr - sign(zbox2,zr)
         end if
      end if
      return
      end


      subroutine write_to_file(outID, prn_pick, prn, elev,
     . azimuth, tod, s1,s2, bad_point,l1,l2,grange,
     .  blockIIRM,L2Ctracking,s5)
      implicit none
      include 'local.inc'
      real*8 s1, s2, tod, elev, azimuth, x,y, l1, l2,w1,w2,
     .  grange, s5
      logical bad_point
      integer prn_pick,outID,L2Ctracking,prn
      integer blockIIRM(maxsat)
c     author: Kristine Larson
c     16jul15 added s5
c     this supports old option that printed out L1 and L2 phase
      w1 = c/f1 ! L1 wavelength in meters
      w2 = c/f2 !L2 wavelength in meters
c     no longer writing out reflection point. columns 5 and 6 are zero
      x = 0
      y = 0

      if (prn_pick.eq.99.and.(elev.gt.5
     .  .and.elev.lt.30)) then
          write(outID,'(i3,  2f10.4, f10.0, 2f7.2, 3f7.2)' )
     .    prn, elev, azimuth, tod, x,y, s1, s2, s5
      elseif ( prn_pick.eq.50 .and.  elev.lt.10 ) then
        write(outID,'(i3,  2f10.4, f10.0, 2f7.2, 2f7.2)' )
     .    prn, elev, azimuth, tod, 0.d0,0.d0, s1, s2
c     all data above 5 degrees
      elseif ( prn_pick.eq.88 .and.  elev.gt.5 ) then
        write(outID,'(i3,  2f10.4, f10.0, 2f7.2, 3f7.2)' )
     .    prn, elev, azimuth, tod, x,y, s1, s2,s5
c     everything < 30
      elseif (  prn_pick.eq.66 .and. elev.lt.30 ) then
        write(outID,'(i3,  2f10.4, f10.0, 2f7.2, 3f7.2)' )
     .    prn, elev, azimuth, tod, 0.d0, 0.d0, s1, s2, s5
c       L2C data only - LLI indicator has to be a zero
c       assumes if no phase data, then it is not a good snr value
      elseif ((prn_pick.eq.77).and.
     .     (blockIIRM(prn).eq.1.and.elev.ge.5))then
        if (.not.bad_point.and.(L2Ctracking.eq.0) ) then
          write(outID,'(i3,  2f10.4, f10.0, 2f7.2, 3f7.2)' )
     .        prn, elev, azimuth, tod, x,y,s1, s2,s5
        endif
c     if you only requested a single satellite
      elseif (prn.eq.prn_pick)  then
        write(outID,'(i3,  2f10.4, f10.0, 2f7.2, 3f7.2)' )
     .    prn, elev, azimuth, tod, x,y, s1, s2, s5
      endif
      end