MODULE ldfdyn
  USE oce
  USE dom_oce
  USE phycst
  USE ldfslp
  USE ldfc1d_c2d
  USE in_out_manager
  USE iom
  USE timing
  USE lib_mpp
  USE lbclnk
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: ldf_dyn_init
  PUBLIC :: ldf_dyn
  LOGICAL, PUBLIC :: ln_dynldf_OFF
  LOGICAL, PUBLIC :: ln_dynldf_lap
  LOGICAL, PUBLIC :: ln_dynldf_blp
  LOGICAL, PUBLIC :: ln_dynldf_lev
  LOGICAL, PUBLIC :: ln_dynldf_hor
  INTEGER, PUBLIC :: nn_ahm_ijk_t
  REAL(KIND = wp), PUBLIC :: rn_Uv
  REAL(KIND = wp), PUBLIC :: rn_Lv
  REAL(KIND = wp), PUBLIC :: rn_csmc
  REAL(KIND = wp), PUBLIC :: rn_minfac
  REAL(KIND = wp), PUBLIC :: rn_maxfac
  REAL(KIND = wp), PUBLIC :: rn_ahm_b
  INTEGER, PARAMETER, PUBLIC :: np_ERROR = - 10
  INTEGER, PARAMETER, PUBLIC :: np_no_ldf = 00
  INTEGER, PARAMETER, PUBLIC :: np_lap = 10, np_blp = 20
  INTEGER, PARAMETER, PUBLIC :: np_lap_i = 11
  INTEGER, PUBLIC :: nldf_dyn
  LOGICAL, PUBLIC :: l_ldfdyn_time
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ahmt, ahmf
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: dtensq
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: dshesq
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: esqt, esqf
  REAL(KIND = wp) :: r1_2 = 0.5_wp
  REAL(KIND = wp) :: r1_4 = 0.25_wp
  REAL(KIND = wp) :: r1_8 = 0.125_wp
  REAL(KIND = wp) :: r1_12 = 1._wp / 12._wp
  REAL(KIND = wp) :: r1_288 = 1._wp / 288._wp
  CONTAINS
  SUBROUTINE ldf_dyn_init
    INTEGER :: ji, jj, jk
    INTEGER :: ioptio, ierr, inum, ios, inn
    REAL(KIND = wp) :: zah0, zah_max, zUfac
    CHARACTER(LEN = 5) :: cl_Units
    NAMELIST /namdyn_ldf/ ln_dynldf_OFF, ln_dynldf_lap, ln_dynldf_blp, ln_dynldf_lev, ln_dynldf_hor, ln_dynldf_iso, nn_ahm_ijk_t, rn_Uv, rn_Lv, rn_ahm_b, rn_csmc, rn_minfac, rn_maxfac
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namdyn_ldf, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namdyn_ldf in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namdyn_ldf, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namdyn_ldf in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namdyn_ldf)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'ldf_dyn : lateral momentum physics'
      WRITE(numout, FMT = *) '~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namdyn_ldf : set lateral mixing parameters'
      WRITE(numout, FMT = *) '      type :'
      WRITE(numout, FMT = *) '         no explicit diffusion                ln_dynldf_OFF = ', ln_dynldf_OFF
      WRITE(numout, FMT = *) '         laplacian operator                   ln_dynldf_lap = ', ln_dynldf_lap
      WRITE(numout, FMT = *) '         bilaplacian operator                 ln_dynldf_blp = ', ln_dynldf_blp
      WRITE(numout, FMT = *) '      direction of action :'
      WRITE(numout, FMT = *) '         iso-level                            ln_dynldf_lev = ', ln_dynldf_lev
      WRITE(numout, FMT = *) '         horizontal (geopotential)            ln_dynldf_hor = ', ln_dynldf_hor
      WRITE(numout, FMT = *) '         iso-neutral                          ln_dynldf_iso = ', ln_dynldf_iso
      WRITE(numout, FMT = *) '      coefficients :'
      WRITE(numout, FMT = *) '         type of time-space variation         nn_ahm_ijk_t  = ', nn_ahm_ijk_t
      WRITE(numout, FMT = *) '         lateral viscous velocity  (if cst)      rn_Uv      = ', rn_Uv, ' m/s'
      WRITE(numout, FMT = *) '         lateral viscous length    (if cst)      rn_Lv      = ', rn_Lv, ' m'
      WRITE(numout, FMT = *) '         background viscosity (iso-lap case)     rn_ahm_b   = ', rn_ahm_b, ' m2/s'
      WRITE(numout, FMT = *) '      Smagorinsky settings (nn_ahm_ijk_t  = 32) :'
      WRITE(numout, FMT = *) '         Smagorinsky coefficient              rn_csmc       = ', rn_csmc
      WRITE(numout, FMT = *) '         factor multiplier for eddy visc.'
      WRITE(numout, FMT = *) '            lower limit (default 1.0)         rn_minfac    = ', rn_minfac
      WRITE(numout, FMT = *) '            upper limit (default 1.0)         rn_maxfac    = ', rn_maxfac
    END IF
    nldf_dyn = np_ERROR
    ioptio = 0
    IF (ln_dynldf_off) THEN
      nldf_dyn = np_no_ldf
      ioptio = ioptio + 1
    END IF
    IF (ln_dynldf_lap) THEN
      ioptio = ioptio + 1
    END IF
    IF (ln_dynldf_blp) THEN
      ioptio = ioptio + 1
    END IF
    IF (ioptio /= 1) CALL ctl_stop('dyn_ldf_init: use ONE of the 3 operator options (NONE/lap/blp)')
    IF (.NOT. ln_dynldf_OFF) THEN
      ioptio = 0
      IF (ln_dynldf_lev) ioptio = ioptio + 1
      IF (ln_dynldf_hor) ioptio = ioptio + 1
      IF (ln_dynldf_iso) ioptio = ioptio + 1
      IF (ioptio /= 1) CALL ctl_stop('dyn_ldf_init: use ONE of the 3 direction options (level/hor/iso)')
      ierr = 0
      IF (ln_dynldf_lap) THEN
        IF (ln_zco) THEN
          IF (ln_dynldf_lev) nldf_dyn = np_lap
          IF (ln_dynldf_hor) nldf_dyn = np_lap
          IF (ln_dynldf_iso) nldf_dyn = np_lap_i
        END IF
        IF (ln_zps) THEN
          IF (ln_dynldf_lev) nldf_dyn = np_lap
          IF (ln_dynldf_hor) nldf_dyn = np_lap
          IF (ln_dynldf_iso) nldf_dyn = np_lap_i
        END IF
        IF (ln_sco) THEN
          IF (ln_dynldf_lev) nldf_dyn = np_lap
          IF (ln_dynldf_hor) nldf_dyn = np_lap_i
          IF (ln_dynldf_iso) nldf_dyn = np_lap_i
        END IF
      END IF
      IF (ln_dynldf_blp) THEN
        IF (ln_zco) THEN
          IF (ln_dynldf_lev) nldf_dyn = np_blp
          IF (ln_dynldf_hor) nldf_dyn = np_blp
          IF (ln_dynldf_iso) ierr = 2
        END IF
        IF (ln_zps) THEN
          IF (ln_dynldf_lev) nldf_dyn = np_blp
          IF (ln_dynldf_hor) nldf_dyn = np_blp
          IF (ln_dynldf_iso) ierr = 2
        END IF
        IF (ln_sco) THEN
          IF (ln_dynldf_lev) nldf_dyn = np_blp
          IF (ln_dynldf_hor) ierr = 2
          IF (ln_dynldf_iso) ierr = 2
        END IF
      END IF
      IF (ierr == 2) CALL ctl_stop('rotated bi-laplacian operator does not exist')
      IF (nldf_dyn == np_lap_i) l_ldfslp = .TRUE.
    END IF
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      SELECT CASE (nldf_dyn)
      CASE (np_no_ldf)
        WRITE(numout, FMT = *) '   ==>>>   NO lateral viscosity'
      CASE (np_lap)
        WRITE(numout, FMT = *) '   ==>>>   iso-level laplacian operator'
      CASE (np_lap_i)
        WRITE(numout, FMT = *) '   ==>>>   rotated laplacian operator with iso-level background'
      CASE (np_blp)
        WRITE(numout, FMT = *) '   ==>>>   iso-level bi-laplacian operator'
      END SELECT
      WRITE(numout, FMT = *)
    END IF
    l_ldfdyn_time = .FALSE.
    IF (ln_dynldf_OFF) THEN
      IF (lwp) WRITE(numout, FMT = *) '   ==>>>   No viscous operator selected. ahmt and ahmf are not allocated'
      RETURN
    ELSE
      ALLOCATE(ahmt(jpi, jpj, jpk), ahmf(jpi, jpj, jpk), STAT = ierr)
      IF (ierr /= 0) CALL ctl_stop('STOP', 'ldf_dyn_init: failed to allocate arrays')
      !$ACC KERNELS
      ahmt(:, :, jpk) = 0._wp
      ahmf(:, :, jpk) = 0._wp
      !$ACC END KERNELS
      IF (ln_dynldf_lap) THEN
        zufac = r1_2 * rn_uv
        inn = 1
        cl_units = ' m2/s'
      ELSE IF (ln_dynldf_blp) THEN
        zufac = r1_12 * rn_uv
        inn = 3
        cl_units = ' m4/s'
      END IF
      zah0 = zUfac * rn_Lv ** inn
      zah_max = zUfac * (ra * rad) ** inn
      SELECT CASE (nn_ahm_ijk_t)
      CASE (0)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity. = constant = ', zah0, cl_Units
        !$ACC KERNELS
        ahmt(:, :, 1 : jpkm1) = zah0
        ahmf(:, :, 1 : jpkm1) = zah0
        !$ACC END KERNELS
      CASE (10)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity = F( depth )'
        IF (lwp) WRITE(numout, FMT = *) '           surface viscous coef. = constant = ', zah0, cl_Units
        !$ACC KERNELS
        ahmt(:, :, 1) = zah0
        ahmf(:, :, 1) = zah0
        !$ACC END KERNELS
        CALL ldf_c1d('DYN', ahmt(:, :, 1), ahmf(:, :, 1), ahmt, ahmf)
      CASE (- 20)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity = F(i,j) read in eddy_viscosity.nc file'
        CALL iom_open('eddy_viscosity_2D.nc', inum)
        CALL iom_get(inum, jpdom_data, 'ahmt_2d', ahmt(:, :, 1))
        CALL iom_get(inum, jpdom_data, 'ahmf_2d', ahmf(:, :, 1))
        CALL iom_close(inum)
        !$ACC KERNELS
        DO jk = 2, jpkm1
          ahmt(:, :, jk) = ahmt(:, :, 1)
          ahmf(:, :, jk) = ahmf(:, :, 1)
        END DO
        !$ACC END KERNELS
      CASE (20)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity = F( e1, e2 ) or F( e1^3, e2^3 ) (lap. or blp. case)'
        IF (lwp) WRITE(numout, FMT = *) '           using a fixed viscous velocity = ', rn_Uv, ' m/s   and   Lv = Max(e1,e2)'
        CALL ldf_c2d('DYN', zUfac, inn, ahmt, ahmf)
      CASE (- 30)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity = F(i,j,k) read in eddy_viscosity_3D.nc file'
        CALL iom_open('eddy_viscosity_3D.nc', inum)
        CALL iom_get(inum, jpdom_data, 'ahmt_3d', ahmt)
        CALL iom_get(inum, jpdom_data, 'ahmf_3d', ahmf)
        CALL iom_close(inum)
      CASE (30)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity = F( latitude, longitude, depth )'
        IF (lwp) WRITE(numout, FMT = *) '           using a fixed viscous velocity = ', rn_Uv, ' m/s   and   Ld = Max(e1,e2)'
        CALL ldf_c2d('DYN', zUfac, inn, ahmt, ahmf)
        CALL ldf_c1d('DYN', ahmt(:, :, 1), ahmf(:, :, 1), ahmt, ahmf)
      CASE (31)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity = F( latitude, longitude, depth , time )'
        IF (lwp) WRITE(numout, FMT = *) '           proportional to the local velocity : 1/2 |u|e (lap) or 1/12 |u|e^3 (blp)'
        l_ldfdyn_time = .TRUE.
      CASE (32)
        IF (lwp) WRITE(numout, FMT = *) '   ==>>>   eddy viscosity = F( latitude, longitude, depth , time )'
        IF (lwp) WRITE(numout, FMT = *) '           proportional to the local deformation rate and gridscale (Smagorinsky)'
        l_ldfdyn_time = .TRUE.
        ALLOCATE(dtensq(jpi, jpj), dshesq(jpi, jpj), esqt(jpi, jpj), esqf(jpi, jpj), STAT = ierr)
        IF (ierr /= 0) CALL ctl_stop('STOP', 'ldf_dyn_init: failed to allocate Smagorinsky arrays')
        !$ACC KERNELS
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            esqt(ji, jj) = (e1e2t(ji, jj) / (e1t(ji, jj) + e2t(ji, jj))) ** 2
            esqf(ji, jj) = (e1e2f(ji, jj) / (e1f(ji, jj) + e2f(ji, jj))) ** 2
          END DO
        END DO
        !$ACC END KERNELS
      CASE DEFAULT
        CALL ctl_stop('ldf_dyn_init: wrong choice for nn_ahm_ijk_t, the type of space-time variation of ahm')
      END SELECT
      IF (.NOT. l_ldfdyn_time) THEN
        IF (ln_dynldf_lap) THEN
          !$ACC KERNELS
          ahmt(:, :, 1 : jpkm1) = ahmt(:, :, 1 : jpkm1) * tmask(:, :, 1 : jpkm1)
          ahmf(:, :, 1 : jpkm1) = ahmf(:, :, 1 : jpkm1) * fmask(:, :, 1 : jpkm1)
          !$ACC END KERNELS
        ELSE IF (ln_dynldf_blp) THEN
          !$ACC KERNELS
          ahmt(:, :, 1 : jpkm1) = SQRT(ahmt(:, :, 1 : jpkm1)) * tmask(:, :, 1 : jpkm1)
          ahmf(:, :, 1 : jpkm1) = SQRT(ahmf(:, :, 1 : jpkm1)) * fmask(:, :, 1 : jpkm1)
          !$ACC END KERNELS
        END IF
      END IF
    END IF
  END SUBROUTINE ldf_dyn_init
  SUBROUTINE ldf_dyn(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zu2pv2_ij_p1, zu2pv2_ij, zu2pv2_ij_m1, zetmax, zefmax
    REAL(KIND = wp) :: zcmsmag, zstabf_lo, zstabf_up, zdelta, zdb
    IF (ln_timing) CALL timing_start('ldf_dyn')
    SELECT CASE (nn_ahm_ijk_t)
    CASE (31)
      IF (ln_dynldf_lap) THEN
        !$ACC KERNELS
        DO jk = 1, jpkm1
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              zu2pv2_ij_p1 = ub(ji, jj + 1, jk) * ub(ji, jj + 1, jk) + vb(ji + 1, jj, jk) * vb(ji + 1, jj, jk)
              zu2pv2_ij = ub(ji, jj, jk) * ub(ji, jj, jk) + vb(ji, jj, jk) * vb(ji, jj, jk)
              zu2pv2_ij_m1 = ub(ji - 1, jj, jk) * ub(ji - 1, jj, jk) + vb(ji, jj - 1, jk) * vb(ji, jj - 1, jk)
              zetmax = MAX(e1t(ji, jj), e2t(ji, jj))
              zefmax = MAX(e1f(ji, jj), e2f(ji, jj))
              ahmt(ji, jj, jk) = SQRT((zu2pv2_ij + zu2pv2_ij_m1) * r1_288) * zetmax * tmask(ji, jj, jk)
              ahmf(ji, jj, jk) = SQRT((zu2pv2_ij + zu2pv2_ij_p1) * r1_288) * zefmax * fmask(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      ELSE IF (ln_dynldf_blp) THEN
        !$ACC KERNELS
        DO jk = 1, jpkm1
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              zu2pv2_ij_p1 = ub(ji, jj + 1, jk) * ub(ji, jj + 1, jk) + vb(ji + 1, jj, jk) * vb(ji + 1, jj, jk)
              zu2pv2_ij = ub(ji, jj, jk) * ub(ji, jj, jk) + vb(ji, jj, jk) * vb(ji, jj, jk)
              zu2pv2_ij_m1 = ub(ji - 1, jj, jk) * ub(ji - 1, jj, jk) + vb(ji, jj - 1, jk) * vb(ji, jj - 1, jk)
              zetmax = MAX(e1t(ji, jj), e2t(ji, jj))
              zefmax = MAX(e1f(ji, jj), e2f(ji, jj))
              ahmt(ji, jj, jk) = SQRT(SQRT((zu2pv2_ij + zu2pv2_ij_m1) * r1_288) * zetmax) * zetmax * tmask(ji, jj, jk)
              ahmf(ji, jj, jk) = SQRT(SQRT((zu2pv2_ij + zu2pv2_ij_p1) * r1_288) * zefmax) * zefmax * fmask(ji, jj, jk)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      END IF
      CALL lbc_lnk_multi(ahmt, 'T', 1., ahmf, 'F', 1.)
    CASE (32)
      IF (ln_dynldf_lap .OR. ln_dynldf_blp) THEN
        !$ACC KERNELS
        zcmsmag = (rn_csmc / rpi) ** 2
        zstabf_lo = rn_minfac * rn_minfac / (2._wp * 4._wp * zcmsmag)
        zstabf_up = rn_maxfac / (4._wp * zcmsmag * 2._wp * rdt)
        IF (ln_dynldf_blp) zstabf_lo = (16._wp / 9._wp) * zstabf_lo
        DO jk = 1, jpkm1
          DO jj = 2, jpj
            DO ji = 2, jpi
              zdb = ((ub(ji, jj, jk) * r1_e2u(ji, jj) - ub(ji - 1, jj, jk) * r1_e2u(ji - 1, jj)) * r1_e1t(ji, jj) * e2t(ji, jj) - (vb(ji, jj, jk) * r1_e1v(ji, jj) - vb(ji, jj - 1, jk) * r1_e1v(ji, jj - 1)) * r1_e2t(ji, jj) * e1t(ji, jj)) * tmask(ji, jj, jk)
              dtensq(ji, jj) = zdb * zdb
            END DO
          END DO
          DO jj = 1, jpjm1
            DO ji = 1, jpim1
              zdb = ((ub(ji, jj + 1, jk) * r1_e1u(ji, jj + 1) - ub(ji, jj, jk) * r1_e1u(ji, jj)) * r1_e2f(ji, jj) * e1f(ji, jj) + (vb(ji + 1, jj, jk) * r1_e2v(ji + 1, jj) - vb(ji, jj, jk) * r1_e2v(ji, jj)) * r1_e1f(ji, jj) * e2f(ji, jj)) * fmask(ji, jj, jk)
              dshesq(ji, jj) = zdb * zdb
            END DO
          END DO
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              zu2pv2_ij_p1 = ub(ji, jj + 1, jk) * ub(ji, jj + 1, jk) + vb(ji + 1, jj, jk) * vb(ji + 1, jj, jk)
              zu2pv2_ij = ub(ji, jj, jk) * ub(ji, jj, jk) + vb(ji, jj, jk) * vb(ji, jj, jk)
              zu2pv2_ij_m1 = ub(ji - 1, jj, jk) * ub(ji - 1, jj, jk) + vb(ji, jj - 1, jk) * vb(ji, jj - 1, jk)
              zdelta = zcmsmag * esqt(ji, jj)
              ahmt(ji, jj, jk) = zdelta * SQRT(dtensq(ji, jj) + r1_4 * (dshesq(ji, jj) + dshesq(ji, jj - 1) + dshesq(ji - 1, jj) + dshesq(ji - 1, jj - 1)))
              ahmt(ji, jj, jk) = MAX(ahmt(ji, jj, jk), SQRT((zu2pv2_ij + zu2pv2_ij_m1) * zdelta * zstabf_lo))
              ahmt(ji, jj, jk) = MIN(ahmt(ji, jj, jk), zdelta * zstabf_up)
              zdelta = zcmsmag * esqf(ji, jj)
              ahmf(ji, jj, jk) = zdelta * SQRT(dshesq(ji, jj) + r1_4 * (dtensq(ji, jj) + dtensq(ji, jj + 1) + dtensq(ji + 1, jj) + dtensq(ji + 1, jj + 1)))
              ahmf(ji, jj, jk) = MAX(ahmf(ji, jj, jk), SQRT((zu2pv2_ij + zu2pv2_ij_p1) * zdelta * zstabf_lo))
              ahmf(ji, jj, jk) = MIN(ahmf(ji, jj, jk), zdelta * zstabf_up)
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      END IF
      IF (ln_dynldf_blp) THEN
        !$ACC KERNELS
        DO jk = 1, jpkm1
          DO jj = 2, jpjm1
            DO ji = 2, jpim1
              ahmt(ji, jj, jk) = SQRT(r1_8 * esqt(ji, jj) * ahmt(ji, jj, jk))
              ahmf(ji, jj, jk) = SQRT(r1_8 * esqf(ji, jj) * ahmf(ji, jj, jk))
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      END IF
      CALL lbc_lnk_multi(ahmt, 'T', 1., ahmf, 'F', 1.)
    END SELECT
    CALL iom_put("ahmt_2d", ahmt(:, :, 1))
    CALL iom_put("ahmf_2d", ahmf(:, :, 1))
    CALL iom_put("ahmt_3d", ahmt(:, :, :))
    CALL iom_put("ahmf_3d", ahmf(:, :, :))
    IF (ln_timing) CALL timing_stop('ldf_dyn')
  END SUBROUTINE ldf_dyn
END MODULE ldfdyn


c 25.04.2003 Link routines between QGSJet and epos.
c author T. Pierog

c-----------------------------------------------------------------------
      subroutine IniQGSJet
c-----------------------------------------------------------------------
c Primary initialization for QGSJet
c-----------------------------------------------------------------------
      include 'epos.inc'
      COMMON /Q_DEBUG/  DEBUG
      COMMON /Q_AREA43/ MONIOU
      integer debug
      double precision BQGS,BMAXQGS,BMAXNEX,BMINNEX,XA(210,3),XB(210,3)
      COMMON /Q_QGSNEX1/ XA,XB,BQGS,BMAXQGS,BMAXNEX,BMINNEX  !ctp

      call utpri('iniqgs',ish,ishini,6)
      write(ifmt,'(a,i6)')'initialize QGSJet ...'

      debug=0
      if(ish.ge.3)debug=ish-2
      moniou=ifch

c common model parameters setting
      call psaset
c particular model parameters setting
      call xxaset
c common initialization procedure
      call qgspsaini
      BMAXNEX=dble(bmaxim)
      BMINNEX=dble(bminim)
      egymin=0.1
      egymax=egymax
      irescl=0

      call utprix('iniqgs',ish,ishini,6)
      end

c-----------------------------------------------------------------------
      subroutine IniEvtQGS
c-----------------------------------------------------------------------
c Initialization for each type of event (for given proj, targ and egy)
c-----------------------------------------------------------------------
      include 'epos.inc'
      common/geom/rmproj,rmtarg,bmax,bkmx
c QGSJet Common
      double precision XA(210,3),XB(210,3),BQGS,BMAXQGS,BMAXNEX,BMINNEX
     &  ,e0
      COMMON /Q_QGSNEX1/ XA,XB,BQGS,BMAXQGS,BMAXNEX,BMINNEX

      if(matarg.gt.210.or.maproj.gt.210)
     &  call utstop('Nucleus too big for QGSJet (Mmax=210) !&')
      call iclass(idproj,iclpro)
      call iclass(idtarg,icltar)
      e0=dble(elab)
      icp=idtrafo('nxs','qgs',idproj)
      if(icp.eq.0)icp=1-2*int(rangen()+0.5)       !pi0=pi+ or p-
      call xxaini(e0,icp,maproj,matarg)
      bmax=BMAXQGS
      qgsincs=fqgscrse(ekin,maproj,matarg)
      if(engy.lt.egymin)qgsincs=0.          !below egymin, no interaction
      call xsigma
      bkmx=sqrt(sigine/10./pi)        !10= fm^2 -> mb
      if(ish.ge.2)write(ifch,*)
     &  'QGSJet used with (E,proj,maproj,matarg,bmax)',e0,icp,maproj
     &  ,matarg,bmax

      return
      end

c-----------------------------------------------------------------------
      subroutine emsqgs(iret)
c-----------------------------------------------------------------------
c  call qgsjet to simulate interaction
c-----------------------------------------------------------------------
      include 'epos.inc'
      include 'epos.incems'
      common/geom/rmproj,rmtarg,bmax,bkmx
      double precision XA(210,3),XB(210,3),BQGS,BMAXQGS,BMAXNEX,BMINNEX
      COMMON /Q_QGSNEX1/ XA,XB,BQGS,BMAXQGS,BMAXNEX,BMINNEX
      common/nucl3/phi,bimp
      common /q_area12/ nsp
      common /q_area14/ esp(4,95000),ich(95000)
      double precision esp
c NSF - number of secondary fragments;
c IAF(i) - mass of the i-th fragment
      COMMON /Q_AREA13/ NSF,IAF(210)
      COMMON /Q_AREA99/ NWT

      iret=0
      b1=bminim
      b2=min(bmax,bmaxim)
      a=pi*(b2**2-b1**2)

      if(a.gt.0..and.rangen().gt.qgsincs/10./a)goto 1001   !no interaction
      if(ish.ge.3)call alist('Determine QGSJet Production&',0,0)

      nptl=0
      nsp=0
      call psconf

      nevt=1
      kolevt=-1
      koievt=-1
      kohevt=-1
      npjevt=maproj
      ntgevt=matarg
      pmxevt=pnll
      egyevt=engy
      if(BQGS.ge.0.d0)then
        bimevt=real(BQGS)
        bimp=real(BQGS)
        phievt=2.*pi*rangen()
      else
        bimevt=0.
        bimp=0.
        phievt=0.
      endif
      anintine=anintine+1.

      call conre
      call conwr

c keep the projectile spectators as fragments
      npns=0
      npps=0
      ns=0
      if(infragm.eq.2)then

        if(NSF.gt.0)then
          do is=1,NSF           !count the number of spectators
          if(ish.ge.7)write(ifch,'(a,i5,a,i5)')
     $       ' Projecticle Fragment ',is,' Mass :',IAF(is)
            nptl=nptl+1
            istptl(nptl)=0
            if(IAF(is).eq.1)then
              id=idptl(is)
              pptl(3,nptl)=pptl(3,is)
              pptl(4,nptl)=pptl(4,is)
              pptl(5,nptl)=pptl(5,is)
              if(id.eq.1120)npps=npps+1
              if(id.eq.1220)npns=npns+1
            else
              if(IAF(is).eq.2)then
                id=17
                npps=npps+1
                npns=npns+1
              elseif(IAF(is).eq.3)then
                id=18
                npps=npps+1
                npns=npns+2
              elseif(IAF(is).eq.4)then
                id=19
                npps=npps+2
                npns=npns+2
              else
                inucl=IAF(is)
                iprot= int(dble(inucl) / 2.15d0 + 0.7d0)
                id=1000000000+iprot*10000+inucl*10 !code for nuclei
                npps=npps+iprot
                npns=npns+inucl-iprot
              endif
              call idmass(id,am)
              pptl(4,nptl)=dble(IAF(is))*pptl(4,is)      !Etot
              pptl(5,nptl)=am                             !mass
              pz2tmp=(pptl(4,nptl)+am)*(pptl(4,nptl)-am)
              if(pz2tmp.gt.0.d0)then
                pptl(3,nptl)=sqrt(pz2tmp)                 !Pz
              else
                write(*,*)'Warning in emsqgs !'
                write(*,*)'energy of fragment too small :',IAF(is),am
     &                     ,pptl(4,nptl)
                pptl(3,nptl)=pptl(4,nptl)
              endif
            endif
            pptl(1,nptl)=0.d0 !P_x
            pptl(2,nptl)=0.d0 !P_y
            ityptl(nptl)=0
            iorptl(nptl)=1
            jorptl(nptl)=maproj+matarg
            ifrptl(1,nptl)=0
            ifrptl(2,nptl)=0
            xorptl(1,nptl)=0.d0
            xorptl(2,nptl)=0.d0
            xorptl(3,nptl)=0.d0
            xorptl(4,nptl)=0.d0
            tivptl(1,nptl)=0.d0
            tivptl(2,nptl)=0.d0
            idptl(nptl)=id
            if(ish.ge.5)write(ifch,'(a,i5,a,i5,a,4(e10.4,1x),f6.3)')
     $       ' Fragment from qgsjet ',nptl,' id :',idptl(nptl)
     $  , ' momentum :',(pptl(k,nptl),k=1,5)

          enddo
        endif

c make the projectile spectators as free nucleons

      else
        ns=0
        if(NSF.gt.0)then
          do is=1,NSF           !count the number of spectators
            ns=ns+IAF(is)
          enddo
          if(infragm.eq.1)then
c  remaining nucleus is one fragment
            nptl=nptl+1
            istptl(nptl)=0
            pptl(1,nptl)=0.d0
            pptl(2,nptl)=0.d0
            pptl(4,nptl)=0.d0
            inucl=0
            do is=1,ns
              inucl=inucl+1
              pptl(4,nptl)=pptl(4,nptl)+pptl(4,is)
            enddo
            iprot= int(dble(inucl) / 2.15d0 + 0.7d0)
            idnucl=1000000000+iprot*10000+inucl*10 !code for nuclei
            npps=npps+iprot
            npns=npns+inucl-iprot
            call idmass(idnucl,am)
            pptl(5,nptl)=am  !mass
            ptot=(pptl(4,nptl)+am)*(pptl(4,nptl)-am)
            pptl(3,nptl)=sqrt(ptot)
            ityptl(nptl)=0
            istptl(nptl)=0
            iorptl(nptl)=1
            jorptl(nptl)=maproj
            ifrptl(1,nptl)=0
            ifrptl(2,nptl)=0
            xorptl(1,nptl)=xorptl(1,1)
            xorptl(2,nptl)=xorptl(2,1)
            xorptl(3,nptl)=xorptl(3,1)
            xorptl(4,nptl)=xorptl(4,1)
            tivptl(1,nptl)=tivptl(1,1)
            tivptl(2,nptl)=tivptl(2,1)
            idptl(nptl)=idnucl
          else
            do is=maproj-ns+1,maproj          !make the ns last projectile nucleon final
              if(idptl(is).eq.1120)npps=npps+1
              if(idptl(is).eq.1220)npns=npns+1
            enddo
          endif
        endif
      endif

c number of participants
      if(laproj.gt.1)then
        npjevt=maproj-npps-npns
        npppar=max(0,laproj-npps)
        npnpar=npjevt-npppar
c set participant projectile as non spectators
        do i=1,maproj
          if(idptl(i).eq.1120)then
            if(npppar.gt.0)then
              npppar=npppar-1
            else                !restore spectators
              iorptl(i)=0
              if(infragm.eq.0)istptl(i)=0
            endif
          endif
          if(idptl(i).eq.1220)then
            if(npnpar.gt.0)then
              npnpar=npnpar-1
            else                !restore spectators
              iorptl(i)=0
              if(infragm.eq.0)istptl(i)=0
            endif
          endif
        enddo
      endif

c restore target spectators
      ns=0
      if(NWT.lt.matarg)then
c number of participants
        ntgevt=NWT
        do is=ntgevt+1,matarg         !make the last target nucleon final
          iorptl(maproj+is)=0
          istptl(maproj+is)=0
        enddo
      endif

      do is=1,nsp

c ich is the type of secondary hadron, esp - its transverse momentum,
c and its energy
c the following notations for the particles types are used: 0 - pi0, 1 -
c pi+,
c -1 - pi-, 2 - p, -2 - p, 3 - n, -3 - n, 4 - k+, -4 - k-, 5 - k0s, -5 -
c k0l
          ic=ich(is)
          if(ish.ge.7)write(ifch,'(a,i5,a,i5,2a,4(e10.4,1x))')
     $       ' qgsjet particle ',is,' id :',ic,' before conversion'
     $     , ' momentum :',(esp(k,is),k=1,4)

            nptl=nptl+1
            if(nptl.gt.mxptl)call utstop('qgsjet: mxptl too small&')
            id=idtrafo('qgs','nxs',ic)
            if(ish.ge.7)write(ifch,'(a,i5,a,i5,a)')
     $       ' epos particle ',nptl,' id :',id,' after conversion'
            call idmass(id,am)

            pptl(1,nptl)=real(esp(3,is)) !P_x
            pptl(2,nptl)=real(esp(4,is)) !P_y
            pptl(3,nptl)=real(esp(2,is)) !P_z
            pptl(4,nptl)=real(esp(1,is)) !E
            pptl(5,nptl)=am              !mass
            istptl(nptl)=0
            ityptl(nptl)=0
            iorptl(nptl)=1
            jorptl(nptl)=maproj+matarg
            ifrptl(1,nptl)=0
            ifrptl(2,nptl)=0
            xorptl(1,nptl)=0.
            xorptl(2,nptl)=0.
            xorptl(3,nptl)=0.
            xorptl(4,nptl)=0.
            tivptl(1,nptl)=0.
            tivptl(2,nptl)=0.
            idptl(nptl)=id

            if(noebin.lt.0)pptl(3,nptl)=-pptl(3,nptl) !exchange projectile <-> target side in case of fake DIS

            if(ish.ge.5)write(ifch,'(a,i5,a,i5,a,4(e10.4,1x),f6.3)')
     $       ' particle from qgsjet ',nptl,' id :',idptl(nptl)
     $  , ' momentum :',(pptl(k,nptl),k=1,5)

      enddo

1000  return

1001  iret=-1
      goto 1000

      end

c------------------------------------------------------------------------------
      function fqgscrse(ek,mapr,matg)
c------------------------------------------------------------------------------
c hadron-nucleus (hadron-proton) and nucl-nucl particle production cross section
c with qgsjet.
c ek - kinetic lab energy
c maproj - projec mass number     (1<maproj<210)
c matarg - target mass number     (1<matarg<210)
c------------------------------------------------------------------------------
      dimension wk(3),wa(3),wb(3)
      include 'epos.inc'
      double precision gsect,qgsasect
      COMMON /Q_XSECT/  GSECT(10,5,4)
      COMMON /Q_AREA48/ QGSASECT(10,6,4)

      fqgscrse=0.
      call idmass(1120,amt1)
      call idmass(1220,amt2)
      amtar=0.5*(amt1+amt2)
      if(matg.eq.1)amtar=amt1
      if(mapr.eq.1)then
        call idmass(idproj,ampro)
      else
        ampro=mapr*amtar
      endif
      egy=ek+ampro
      ye=max(1.,log10(egy))
      je=min(8,int(ye))

      wk(2)=ye-je
      wk(3)=wk(2)*(wk(2)-1.)*.5
      wk(1)=1.-wk(2)+wk(3)
      wk(2)=wk(2)-2.*wk(3)

      ya=real(matg)
      ya=log(ya)/1.38629+1.
      ja=min(int(ya),2)
      wa(2)=ya-ja
      wa(3)=wa(2)*(wa(2)-1.)*.5
      wa(1)=1.-wa(2)+wa(3)
      wa(2)=wa(2)-2.*wa(3)

      if(mapr.eq.1)then

        do i=1,3
          do m=1,3
         fqgscrse=fqgscrse+real(gsect(je+i-1,iclpro,ja+m-1))*wk(i)*wa(m)
          enddo
        enddo

      else

        yb=mapr
        yb=log(yb/2.)/.69315+1.
        jb=min(int(yb),4)
        wb(2)=yb-jb
        wb(3)=wb(2)*(wb(2)-1.)*.5
        wb(1)=1.-wb(2)+wb(3)
        wb(2)=wb(2)-2.*wb(3)

        do i=1,3
          do m=1,3
            do n=1,3
              fqgscrse=fqgscrse+real(qgsasect(je+i-1,jb+n-1,ja+m-1)
     &                     *wk(i)*wa(m)*wb(n))
            enddo
          enddo
        enddo

      endif

      fqgscrse=exp(fqgscrse)
      return
      end

c------------------------------------------------------------------------------
      function qgscrse(egy,mapro,matar,id)
c------------------------------------------------------------------------------
c inelastic cross section of qgsjet
c (id=0 corresponds to air)
c egy - kintetic energy
c maproj - projec mass number     (1<maproj<210)
c matarg - target mass number     (1<matarg<210)
c------------------------------------------------------------------------------
      include 'epos.inc'

      qgscrse=0.
      if(id.eq.0)then
        do k=1,3
          mt=int(airanxs(k))
          qgscrse=qgscrse+airwnxs(k)*fqgscrse(egy,mapro,mt)
        enddo
      else
        qgscrse=fqgscrse(egy,mapro,matar)
      endif

      return
      end

c--------------------------------------------------------------------
      double precision function psran(b10)

c--------------------------------------------------------------------
c  Random number generator
c--------------------------------------------------------------------
      double precision b10,drangen
      include 'epos.inc'
      psran=drangen(b10)
      if(irandm.eq.1)write(ifch,*)'psran()= ',psran

      return
      end


      subroutine pcraq(aamatr,apr,atwt,avgrid,cdrs,cdrsi,cess,cessi,
     $ cof,dhfe,dhfs,dvfe,dvfs,eps100,gmmatr,ipch,ipchmx,ipcv,ipcvmx,
     $ ipivot,itgenf,mtotr,nacdpr,narxmx,narxt,nat,natmax,nbt,nbtmx1,
     $ nbtmx2,nch,nco,nct,nctmax,ndata1,ndat0s,ndat1f,ndbmax,ndbptg,
     $ ndbptl,nentei,nentri,nerr,nmodwr,noutpt,nsb,nslist,ntprmx,ntprt,
     $ nttyo,nwarn,qelect,q500fl,tempc,tempcs,tmpcmx,uaqsp,udbfmt,
     $ udbval,udrsi,uelem,uessi,uspec,xdbval,xhfe,xhfs,xlke,xlks,xvfe,
     $ xvfs,xvec,yvec,zaqsp,zchar)
c
c     This subroutine reads data on aqueous species from the stripped
c     DATA0 file, processes this data, and writes the results on the
c     DATA1 and DATA1F files. The counter nerr is incremented by
c     one for each error encountered. The counter nwarn is incremented
c     similarly for each warning.
c
c     This subroutine is called by:
c
c       EQPT/eqpt.f
c
c-----------------------------------------------------------------------
c
c     Principal input:
c
c       narxt  = array of numbers of coefficients in the temperature
c                  ranges
c       nbt    = the number of basis species
c       nct    = the number of chemical elements
c       ndata1 = unit number of the DATA1 file
c       ndat0s = unit number of the stripped DATA0 file
c       ndat1f = unit number of the DATA1F file
c       ndbptg = the number of distinct points on the temperature grid
c       ndbptl = the maximum number of points on the temperature grid
c                  per line
c       ntprt  = the number of temperature ranges on the standard
c                  temperature grid
c       qelect = flag denoting the use of "e-" instead of "O2(g)"
c                  in writing chemical reactions
c       tempc  = array of temperatures (on the temperature grid)
c       tempcs = array of scaled temperatures (on the temperature grid)
c       tmpcmx = the max norm of the tempeatures on the temperature grid
c       udbfmt = the format for reading a line of data on the
c                  temperature grid
c
c
c     Principal output:
c
c       atwt   = array of atomic weights
c       cdrs   = array of reaction coefficients
c       cess   = array of elemental composition coefficients
c       nat    = the number of aqueous species
c       nerr   = cumulative error counter
c       nwarn  = cumulative warning counter
c       uaqsp  = array of aqueous species names
c       uelem  = array of names of chemical elements
c       uspec  = array of names of species
c       xlke   = array of log K values for the "Eh" reaction (on the
c                  temperature grid)
c       xlks   = array of log K values for reactions
c       zaqsp  = array of charge numbers of aqueous species
c       zchar  = array of electrical charge numbers of species
c
c     Workspace:
c
c       aamatr = matrix used to calculate the polynomial coefficients
c       apr    = array of polynomial coefficients (for all ranges)
c       avgrid = array containing the data on the temperature grid
c       cof    = array of fitted polynomial coefficients (for a
c                  single temperature range)
c       gmmatr = a copy of the amatr matrix
c       ipivot = the pivot vector, used in solving matrix equations
c       nacdpr = array containging the number of actual data points
c                  by range on the "log K" temperature grid; excludes
c       udbval = string array for reading data on the temperature grid
c       xdbval = holding space array for data on the temperature grid
c       xvec   = array of scaled temperatures corresponding to the
c                  data in the yvec array
c       yvec   = array of data to be fitted (for a single temperature
c                  range)
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer ipchmx,ipcvmx,narxmx,natmax,nbtmx1,nbtmx2,nctmax,
     $ ndbmax,ntprmx
c
      integer ndata1,ndat0s,ndat1f,noutpt,nslist,nttyo
c
      integer ipivot(narxmx),nacdpr(ntprmx),narxt(ntprmx),
     $ nentei(nctmax),nentri(nbtmx1)
c
      integer ipch,ipcv,itgenf,nat,nbt,nch,nco,nct,ndbptg,ndbptl,nerr,
     $ nmodwr,nsb,ntprt,nwarn
c
      logical qelect,q500fl
c
      character(len=24) uaqsp(natmax),udrsi(nbtmx1),uspec(nbtmx1)
      character(len=16) udbval(ndbmax)
      character(len=8) uelem(nctmax),uessi(nctmax)
c
      character(len=16) udbfmt
c
      real(8) atwt(nctmax),cdrs(nbtmx2,nbtmx1),cdrsi(nbtmx1),
     $ cess(nctmax,nbtmx1),cessi(nctmax),dhfe(narxmx,ntprmx,ipchmx),
     $ dhfs(narxmx,ntprmx,ipchmx,nbtmx1),dvfe(narxmx,ntprmx,ipcvmx),
     $ dvfs(narxmx,ntprmx,ipcvmx,nbtmx1),xhfe(narxmx,ntprmx),
     $ xhfs(narxmx,ntprmx,nbtmx1),xlke(narxmx,ntprmx),
     $ xlks(narxmx,ntprmx,nbtmx1),xvfe(narxmx,ntprmx),
     $ xvfs(narxmx,ntprmx,nbtmx1),zchar(nbtmx1),zaqsp(natmax)
c
      real(8) apr(narxmx,ntprmx),avgrid(narxmx,ntprmx)
      real(8) tempc(narxmx,ntprmx),tempcs(narxmx,ntprmx),tmpcmx(ntprmx)
      real(8) aamatr(narxmx,narxmx),gmmatr(narxmx,narxmx)
      real(8) cof(narxmx),xvec(narxmx),yvec(narxmx)
      real(8) xdbval(ndbmax),mtotr(nctmax)
c
      real(8) eps100
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,ii,ipc,j,j2,j3,j4,j5,k,n,nbt1,nbw,nc,ncount,ncts,ndrsts,
     $ nmodx,nn,nnx,ns,nse,nsm1,nspnx,nt,ntpr,nxm
c
      integer ilnobl
c
      logical qblkes,qblkrs,qend,qerr,qnofes,qnofrs,qzeres,qzerrs,
     $ q500nd
c
      character(len=24) uspn(2)
c
      character(len=80) ulbufa,ulbufb,uline,ux80
      character(len=72) uterm,utermc
      character(len=56) ustrgr
      character(len=24) uaq24,uend24,ublk24,unone,usblkf,ux24
      character(len=16) ux16
      character(len=8) uaqu,uaux,ux8,ux8a,ux8b,ux8c,uendit,usol
c
      real(8) mwtss,zx
c
c-----------------------------------------------------------------------
c
      data ublk24 /'                        '/
      data uaq24 /'aqueous                 '/
      data unone /'none                    '/
      data uendit /'endit.  '/
      data uaux /'auxiliar'/
      data uaqu /'aqueous '/
      data usol /'solids  '/
c
c-----------------------------------------------------------------------
c
      uterm(1:48) = '+-----------------------------------------------'
      uterm(49:72) = '------------------------'
      utermc = uterm
      utermc(1:1) = '*'
c
c     The variable nn must be set to zero here to provide a proper
c     diagnostic if an early end-of-file or read format error occurs.
c
      nn = 0
c
      q500nd = q500fl
c
c     Set the expected index of H2O.
c
      nbw = 1
c
c     Skip 2 lines to the 'basis species' delimiter.
c
      read (ndat0s,1000,end=990,err=995) uline
      read (ndat0s,1000,end=990,err=995) uline
 1000 format(a)
c
c     Write label.
c
      usblkf = uaq24
      j3 = ilnobl(uaq24)
      write (ndata1) uaq24
      write (ndat1f,1010) uaq24(1:j3)
 1010 format(a)
      write (ndat1f,1010) utermc(1:72)
      write (noutpt,1020) uaq24(1:j3)
      write (nttyo,1020) uaq24(1:j3)
      write (nslist,1020) uaq24(1:j3)
 1020 format(//1x,a,/)
c
c     Initialize some variables.
c
      qelect = .false.
      uend24(1:8) = uendit(1:8)
      uend24(9:24) = ublk24(9:24)
      uspn(1) = unone
      uspn(2) = ublk24
      nspnx = 1
      nnx = -1
      nn = 1
      nmodx = 0
      nbt1 = nbt + 1
      nat = 0
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Note: the main loop returns here.
c
  100 ns = min(nn,nbt1)
      ncts = 0
      ndrsts = 0
c
      do nc = 1,nct
        cess(nc,ns) = 0.
        cessi(nc) = 0.
      enddo
c
      do nse = 1,nbt1
        cdrs(nse,ns) = 0.
        cdrsi(nse) = 0.
      enddo
      cdrs(nbt + 2,ns) = 0.
c
      call initcv(uessi,nct,' ')
      call initcv(udrsi,nbt1,' ')
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Read the first line of the block.
c
  110 continue
      read (ndat0s,1000,end=990,err=995) uline
      ux24 = uline(1:24)
      ux8 = ux24(1:8)
c
      if (ux8(1:8).eq.uaux(1:8) .or. ux8(1:8).eq.uaqu(1:8)) then
c
c       Skip the terminator line, read the next line.
c
        read (ndat0s,1000,end=990,err=995) uline
        go to 110
c
      elseif (ux8(1:8) .eq. usol(1:8)) then
c
c       Skip the terminator line.
c
        read (ndat0s,1000,end=990,err=995) uline
c
c       Finish and exit here.
c
        if (uspn(1)(1:24) .eq. unone(1:24)) then
          nnx = 0
          nn = 0
          write (nttyo,1140) nnx,unone(1:4)
          write (nslist,1140) nnx,unone(1:4)
 1140     format(1x,i5,2x,a)
          write (noutpt,1150) nn,unone(1:4)
 1150     format(1x,i5,1x,a)
        else
          nxm = nspnx - 1
          if (nxm .ge. 1) then
            nnx = nnx + 2
            if (nxm .eq. 1) then
              j3 = ilnobl(uspn(1))
              write (nttyo,1140) nnx,uspn(1)(1:j3)
              write (nslist,1140) nnx,uspn(1)(1:j3)
            else
              j3 = ilnobl(uspn(2))
              write (nttyo,1160) nnx,uspn(1),uspn(2)(1:j3)
              write (nslist,1160) nnx,uspn(1),uspn(2)(1:j3)
 1160         format(1x,i5,2x,a24,2x,a)
            endif
          elseif (nmodx .ne. 1) then
            j3 = ilnobl(uspn(2))
            write (nttyo,1160) nnx,uspn(1),uspn(2)(1:j3)
          endif
        endif
        write (ndata1) uend24,ublk24,ublk24
        j3 = ilnobl(uend24)
        write (ndat1f,1010) uend24(1:j3)
        write (ndat1f,1010) utermc(1:72)
        if (nerr .gt. 0) stop
        go to 999
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Have a species block.
c
      nat = nat + 1
c
      j2 = ilnobl(ux24)
      if (j2 .le. 0) then
        write (ux8a,'(i5)') nat
        call lejust(ux8a)
        j3 = ilnobl(ux8a)
        j4 = ilnobl(usblkf)
        write (noutpt,1240) ux8a(1:j3),usblkf(1:j4)
        write (nttyo,1240) ux8a(1:j3),usblkf(1:j4)
 1240   format(/' * Error - (EQPT/pcraq) Have encountered a blank',
     $  ' species name',/7x,'for species block ',a,' of the ',a,
     $  ' superblock.')
        if (nat .gt. 1) then
          ux24 = uaqsp(nat - 1)
          j5 = ilnobl(ux24)
          if (j5 .gt. 0) then
            write (noutpt,1250) ux24(1:j5)
            write (nttyo,1250) ux24(1:j5)
 1250       format(7x,'This block follows the one for ',a,'.')
          endif
        endif
        ux24 = '<blank>'
        nerr = nerr + 1
      endif
c
      uaqsp(nat) = ux24
      uspec(ns) = ux24
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Save the species name for screen and SLIST output.
c
      uspn(nspnx) = uspec(ns)
c
c     Write the species name on the OUTPUT file.
c
      j2 = ilnobl(uspec(ns))
      write (noutpt,1150) nn,uspec(ns)(1:j2)
c
c     Write species names two per line on the SLIST file.
c
      nspnx = nspnx + 1
      if (nspnx .gt. 2) then
        nspnx = 1
        nnx = nnx + 2
        nmodx = mod(nnx,nmodwr)
        if (nmodwr .eq. 1) nmodx = 1
        j3 = ilnobl(uspn(2))
        if (nmodx .eq. 1) write (nttyo,1160) nnx,uspn(1),uspn(2)(1:j3)
        write (nslist,1160) nnx,uspn(1),uspn(2)(1:j3)
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Skip the obsolete 'sp.type =' and 'revised =' lines.
c     Read the electrical charge.
c
  130 read (ndat0s,1000,end=990,err=995) uline
      ii = index(uline,'charge')
      if (ii .eq. 0) go to 130
c
      ux80 = uline(ii + 6:80)
      ii = index(ux80,'=')
      ux16 = ux80(ii + 1:80)
      call lejust(ux16)
      read (ux16,'(f5.1)',err=995) zx
c1280 format(14x,f5.1)
      zaqsp(nat) = zx
      zchar(ns) = zx
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Read the number of chemical elements composing the species.
c
      read (ndat0s,1000,end=990,err=995) uline
      ux80 = uline
      call lejust(ux80)
      ii = index(ux80,'element(s)')
      if (ii .gt. 1) then
        ux16 = ux80(1:ii - 1)
        read (ux16,'(i5)',err=995) ncts
c1330   format(4x,i2)
      else
        ii = index(ux80,' ')
        if (ii .gt. 1) then
          ux16 = ux80(1:ii - 1)
          read (ux16,'(i5)',err=995) ncts
        else
          ncts = 0
        endif
      endif
c
      if (ncts .gt. nct) then
        j2 = ilnobl(uspec(ns))
        write (ux8a,'(i5)') ncts
        call lejust(ux8a)
        j3 = ilnobl(ux8a)
        write (ux8c,'(i5)') nct
        call lejust(ux8c)
        j5 = ilnobl(ux8c)
        write (noutpt,1350) uspec(ns)(1:j2),ux8a(1:j3),ux8c(1:j5)
        write (nttyo,1350) uspec(ns)(1:j2),ux8a(1:j3),ux8c(1:j5)
 1350   format(/' * Error - (EQPT/pcraq) Species "',a,'" is',
     $  ' composed of ',a,/7x,'chemical elements, but there',
     $  ' are only ',a,' elements on the data file.')
        nerr = nerr + 1
      endif
c
      if (ncts .le. 0) then
        if (uspec(ns)(1:3).ne.'e- ' .and. uspec(ns)(1:3).ne.'E- ') then
          j2 = ilnobl(uspec(ns))
          write (noutpt,1360) uspec(ns)(1:j2)
          write (nttyo,1360) uspec(ns)(1:j2)
 1360     format(/' * Error - (EQPT/pcraq) Species "',a,'" is not',
     $    ' composed of',/7x,'any chemical elements.')
          nerr = nerr + 1
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Read the names of the elements and the corresponding
c     compositional coefficients.
c
      n = 0
      do i = 1,ncts/3
        read (ndat0s,1000,end=990,err=995) uline
        ulbufa = uline
        do k = 1,3
          call lejust(ulbufa)
          ii = index(ulbufa,' ')
          if (ii .gt. 1) then
            ux16 = ulbufa(1:ii - 1)
            read (ux16,'(f8.4)',err=995) cessi(n + k)
          else
            cessi(n + k) = 0.
          endif
          ulbufb = ulbufa(ii + 1:80)
          call lejust(ulbufb)
          uessi(n + k) = ulbufb(1:8)
          if (k .lt. 3) ulbufa = ulbufb(9:80)
        enddo
c       read (uline,1370,err=995) (cessi(n + k),uessi(n + k), k = 1,3)
c1370   format((4x,3(f8.4,1x,a8,5x)))
        n = n + 3
      enddo
c
      j = mod(ncts,3)
      if (j .gt. 0) then
        read (ndat0s,1000,end=990,err=995) uline
        ulbufa = uline
        do k = 1,j
          call lejust(ulbufa)
          ii = index(ulbufa,' ')
          if (ii .gt. 1) then
            ux16 = ulbufa(1:ii - 1)
            read (ux16,'(f8.4)',err=995) cessi(n + k)
          else
            cessi(n + k) = 0.
          endif
          ulbufb = ulbufa(ii + 1:80)
          call lejust(ulbufb)
          uessi(n + k) = ulbufb(1:8)
          if (k .lt. j) ulbufa = ulbufb(9:80)
        enddo
c       read (uline,1370,err=995) (cessi(n + k),uessi(n + k), k = 1,j)
        n = n + j
      endif
c
c     Check for blank element names, duplicate element names, and
c     zero-valued stoichiometric coefficients.
c
      call elesck(cessi,nbtmx1,nctmax,ncts,nentei,nerr,noutpt,
     $ ns,nttyo,qblkes,qzeres,uessi,usblkf,uspec)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ns .eq. nbw) then
c
c       Make sure that H2O is the first aqueous species.
c
        if (uspec(nbw)(1:4) .ne. 'H2O ') then
          j2 = ilnobl(uspec(nbw))
          write (noutpt,1420) uspec(nbw)(1:j2)
          write (nttyo,1420) uspec(nbw)(1:j2)
 1420     format(/' * Error - (EQPT/pcraq) The first strict basis',
     $    ' species on the data file',/7x,'is ',a,'. The first',
     $    ' strict basis species must be H2O.',/7x,'This is an',
     $    ' idiosyncrasy of EQ3/6.')
          nerr = nerr + 1
        endif
      endif
c
      if (ns .le. nsb) then
c
c       A strict basis species may be composed of only one chemical
c       element other than O or H.
c
        ncount = 0
        do i = 1,ncts
          if (cessi(i) .gt. 0.) then
            if (uessi(i)(1:2).ne.'O ' .and. uessi(i)(1:2).ne.'H ' .and.
     $      uessi(i)(1:7).ne.'<blank>') ncount = ncount + 1
          endif
        enddo
c
        if (ncount .gt. 1) then
          j2 = ilnobl(uspec(ns))
          write (noutpt,1430) uspec(ns)(1:j2)
          write (nttyo,1430) uspec(ns)(1:j2)
 1430     format(/' * Error - (EQPT/pcraq) The strict basis species ',
     $    a,' is composed',/7x,'of more than one chemical element',
     $    ' other than O and H.')
          nerr = nerr + 1
        endif
      endif
c
      if (ns .le. nct) then
c
c       Make sure that there is a 1:1 mapping to the chemical elements
c       for the first nct members of the strict basis set.
c
c       H2O (solvent water) is a special case. H2O always maps to O.
c       Since the first chemical element is required to be O, the first
c       aqueous species is required to  be H2O. Here it is sufficient
c       to make sure that that indeed is the case.
c
        if (ns .eq. 1) then
          if (uspec(ns)(1:4) .ne. 'H2O ') then
            j2 = ilnobl(uspec(ns))
            write (noutpt,1440) uspec(ns)(1:j2)
            write (nttyo,1440) uspec(ns)(1:j2)
 1440       format(/' * Error - (EQPT/pcraq) The first aqueous species',
     $      ' is ',a,'.',/7x,'The first aqueous species must be H2O.')
            nerr = nerr + 1
          endif
        endif
c
c       The hydrogen ion is also a special case. H+ always maps to H.
c
        if (uspec(ns)(1:3) .eq. 'H+ ') then
          nc = ns
          if (uelem(nc)(1:2) .ne. 'H ') then
            j2 = ilnobl(uspec(ns))
            write (noutpt,1450)
            write (nttyo,1450)
 1450       format(/' * Error - (EQPT/pcraq) The species H+ is',
     $      ' required to match',/7x,'the chemical element H. If the',
     $      ' species is the n-th member of',/7x,'the strict',
     $      ' basis set, the corresponding chemical element must be',
     $      /7x,'the n-th chemical element (there is one exception',
     $      ' to this rule,',/7x,"the redox species, which doesn't",
     $      ' correspond to any chemical element).')
            nerr = nerr + 1
          endif
        endif
c
c       Any strict basis species, other than the redox species,
c       must be composed of the chemical element to which it
c       formally corresponds.
c
        nc = ns
        do i = 1,ncts
          if (uessi(i)(1:8) .eq. uelem(nc)(1:8)) then
            if (cessi(i) .gt. 0.) go to 120
          endif
        enddo
c
        j2 = ilnobl(uspec(ns))
        j3 = ilnobl(uelem(nc))
        write (noutpt,1460) uspec(ns)(1:j2),uelem(nc)(1:j3)
        write (nttyo,1460) uspec(ns)(1:j2),uelem(nc)(1:j3)
 1460   format(/' * Error - (EQPT/pcraq) The strict basis',
     $  ' species ',a,' is not',/7x,'composed of the chemical',
     $  ' element ',a,' to which it must correspond.',
     $  /7x,'If the species is the n-th member of the strict',
     $  ' basis set,',/7x,'the, corresponding chemical',
     $  ' element must be the n-th chemical element.',
     $  /7x,'There is one exception to this rule, the',
     $  ' redox species. It must be',/7x,'the last strict',
     $  " basis species, if present. It doesn't correspond",
     $  /7x,'to any chemical element.')
        nerr = nerr + 1
  120   continue
      endif
c
c     Check out the redox species.
c
      if (ns .eq. nsb) then
        if (uspec(ns)(1:6).ne.'O2(g) ' .and.
     $    uspec(ns)(1:3).ne.'e- ' .and.
     $    uspec(ns)(1:3).ne.'E- ') then
          j2 = ilnobl(uspec(ns))
          write (noutpt,1470) uspec(ns)(1:j2)
          write (nttyo,1470) uspec(ns)(1:j2)
 1470     format(/' * Error - (EQPT/pcraq) The redox species is ',a,
     $    '. This must',/7x,'be either O2(g) or e-.')
          nerr = nerr + 1
        endif
      endif
c
      if (ns .eq. nsb) then
        if (nerr .gt. 0) stop
      endif
c
      if (ns .eq. nbt) then
        if (nerr .gt. 0) stop
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      if (ns .gt. nsb) then
c
c       Read number of species in the associated reaction.
c
        read (ndat0s,1000,end=990,err=995) uline
        ux80 = uline
        call lejust(ux80)
        ii = index(ux80,'species')
        if (ii .gt. 1) then
          ux16 = ux80(1:ii - 1)
          read (ux16,'(i5)',err=995) ndrsts
c1500   format(4x,i2)
        else
          ii = index(ux80,' ')
          if (ii .gt. 1) then
            ux16 = ux80(1:ii - 1)
            read (ux16,'(i5)',err=995) ndrsts
          else
            ndrsts = 0
          endif
        endif
c
        if (ndrsts .gt. nbt1) then
          j2 = ilnobl(uspec(ns))
          write (ux8a,'(i5)') ndrsts
          call lejust(ux8a)
          j3 = ilnobl(ux8a)
          write (ux8b,'(i5)') nbt
          call lejust(ux8b)
          j4 = ilnobl(ux8b)
          write (ux8c,'(i5)') nbt1
          call lejust(ux8c)
          j5 = ilnobl(ux8c)
          write (noutpt,1520) uspec(ns)(1:j2),ux8a(1:j3),ux8b(1:j4),
     $    ux8c(1:j5)
          write (nttyo,1520) uspec(ns)(1:j2),ux8a(1:j3),ux8b(1:j4),
     $    ux8c(1:j5)
 1520     format(/' * Error - (EQPT/pcraq) The reaction for the',
     $    /7x,'destruction of species "',a,'" includes ',a,
     $    /7x,'species, but there are only ',a,' basis species on the',
     $    /7x,'data file, so only ',a,' species may appear in the ',
     $    'reaction.')
          nerr = nerr + 1
        endif
c
        if (ndrsts .lt. 2) then
          j2 = ilnobl(uspec(ns))
          j4 = ilnobl(usblkf)
          write (noutpt,1530) uspec(ns)(1:j2),usblkf(1:j4)
          write (nttyo,1530) uspec(ns)(1:j2),usblkf(1:j4)
 1530     format(/' * Error - (EQPT/pcraq) The species ',a,
     $    ' appearing',/7x,'on the data file in the ',a,' superblock',
     $    ' has fewer than',/7x,'two species in its associated',
     $    ' reaction. This is not a',/7x,'valid reaction.')
          nerr = nerr + 1
        endif
c
c       Read the names of the species in the reaction and the
c       corresponding reaction coefficients.
c
        n = 0
        do i = 1,ndrsts/2
          read (ndat0s,1000,end=990,err=995) uline
          ulbufa = uline
          do k = 1,2
            call lejust(ulbufa)
            ii = index(ulbufa,' ')
            if (ii .gt. 1) then
              ux16 = ulbufa(1:ii - 1)
              read (ux16,'(f10.4)',err=995) cdrsi(n + k)
            else
              cdrsi(n + k) = 0.
            endif
            ulbufb = ulbufa(ii + 1:80)
            call lejust(ulbufb)
            udrsi(n + k) = ulbufb(1:24)
            if (k .lt. 2) ulbufa = ulbufb(25:80)
          enddo
c         read (uline,1540,err=995) (cdrsi(n + k),udrsi(n + k), k = 1,2)
c1540     format((2(1x,f10.4,2x,a24)))
          n = n + 2
        enddo
c
        j = mod(ndrsts,2)
        if (j .gt. 0) then
          read (ndat0s,1000,end=990,err=995) uline
          ulbufa = uline
          do k = 1,j
            call lejust(ulbufa)
            ii = index(ulbufa,' ')
            if (ii .gt. 1) then
              ux16 = ulbufa(1:ii - 1)
              read (ux16,'(f10.4)',err=995) cdrsi(n + k)
            else
              cdrsi(n + k) = 0.
            endif
            ulbufb = ulbufa(ii + 1:80)
            call lejust(ulbufb)
            udrsi(n + k) = ulbufb(1:24)
            if (k .lt. j) ulbufa = ulbufb(25:80)
          enddo
c         read (uline,1540,err=995) (cdrsi(n + k),udrsi(n + k), k = 1,j)
          n = n + j
        endif
c
c       Check for blank species names, duplicate species names, and
c       zero-valued reaction coefficients. Check that the reaction
c       coefficient of the species with which the reaction is
c       associated has a negative value.
c
        call rxnsck(nbtmx1,cdrsi,nct,ndrsts,nentri,nerr,noutpt,
     $  ns,nsb,nttyo,qblkrs,qzerrs,udrsi,usblkf,uspec)
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c       Read the log K grid for the current species.
c       Return the data in the xdbval holding array.
c
        call rdgrid(ndat0s,ndbmax,ndbptg,ndbptl,qend,qerr,q500nd,
     $  udbval,xdbval)
        if (qend) go to 990
        if (qerr) go to 995
c
c       Load the data into the xlks array.
c
c       Calling sequence substitutions:
c         ns for ipc
c         nbtmx1 for ipcmax
c         xlks for zdbval
c
        call ldbar3(ns,nbtmx1,nacdpr,narxmx,narxt,ndbmax,
     $  ntprmx,ntprt,xdbval,xlks)
c
        if (itgenf .ge. 0) then
c
c         Test the grid ranges for sparseness of actual data.
c
          ustrgr = 'the log K for ' // uspec(ns)
          call tegrid(itgenf,nacdpr,narxt,nerr,noutpt,ntprmx,
     $    ntprt,nttyo,nwarn,ustrgr)
        endif
      endif
c
c     In the case of a strict basis species (a species which has no
c     real associated reaction), xhfs is the partial molar enthalpy
c     of formation and xvfs is the partial molar volume. In the case
c     of all other species, there is a real associated reaction and
c     xhfs is then the partial molar enthalpy of reaction and xvfs
c     is the partial molar volume of reaction.
c
      if (ipch .ge. 0) then
c
c       Read the enthalpy function grid for the current species.
c       Return the data in the xdbval holding array.
c
        call rdgrid(ndat0s,ndbmax,ndbptg,ndbptl,qend,qerr,q500nd,
     $  udbval,xdbval)
        if (qend) go to 990
        if (qerr) go to 995
c
c       Load the data into the xhfs array.
c
c       Calling sequence substitutions:
c         ns for ipc
c         nbtmx1 for ipcmax
c         xhfs for zdbval
c
        call ldbar3(ns,nbtmx1,nacdpr,narxmx,narxt,ndbmax,
     $  ntprmx,ntprt,xdbval,xhfs)
c
        if (itgenf .ge. 0) then
c
c         Test the grid ranges for sparseness of actual data.
c
          ustrgr = 'the enthalpy function for ' // uspec(ns)
          call tegrid(itgenf,nacdpr,narxt,nerr,noutpt,ntprmx,
     $    ntprt,nttyo,nwarn,ustrgr)
        endif
c
        do ipc = 1,ipch
c
c         Read the enthalpy function derivative grid for the current
c         species. Return the data in the xdbval holding array.
c
          call rdgrid(ndat0s,ndbmax,ndbptg,ndbptl,qend,qerr,q500nd,
     $    udbval,xdbval)
          if (qend) go to 990
          if (qerr) go to 995
c
c         Load the data into the dhfs array.
c
c         Calling sequence substitutions:
c           ipchmx for ipcmax
c           dhfs for zdbval
c
          call ldbar4(ipc,ipchmx,nacdpr,narxmx,narxt,nbtmx1,
     $    ndbmax,ns,ntprmx,ntprt,xdbval,dhfs)
        enddo
      endif
c
      if (ipcv .ge. 0) then
c
c       Read the volume function grid for the current species.
c       Return the data in the xdbval holding array.
c
        call rdgrid(ndat0s,ndbmax,ndbptg,ndbptl,qend,qerr,q500nd,
     $  udbval,xdbval)
        if (qend) go to 990
        if (qerr) go to 995
c
c       Load the data into the xvfs array.
c
c       Calling sequence substitutions:
c         ns for ipc
c         nbtmx1 for ipcmax
c         xvfs for zdbval
c
        call ldbar3(ns,nbtmx1,nacdpr,narxmx,narxt,ndbmax,
     $  ntprmx,ntprt,xdbval,xvfs)
c
        if (itgenf .ge. 0) then
c
c         Test the grid ranges for sparseness of actual data.
c
          ustrgr = 'the volume function for ' // uspec(ns)
          call tegrid(itgenf,nacdpr,narxt,nerr,noutpt,ntprmx,
     $    ntprt,nttyo,nwarn,ustrgr)
        endif
c
        do ipc = 1,ipcv
c
c         Read the volume function derivative grid for the current
c         species. Return the data in the xdbval holding array.
c
          call rdgrid(ndat0s,ndbmax,ndbptg,ndbptl,qend,qerr,q500nd,
     $    udbval,xdbval)
          if (qend) go to 990
          if (qerr) go to 995
c
c         Load the data into the dvfs array.
c
c         Calling sequence substitutions:
c           ipcvmx for ipcmax
c           dvfs for zdbval
c
          call ldbar4(ipc,ipcvmx,nacdpr,narxmx,narxt,nbtmx1,
     $    ndbmax,ns,ntprmx,ntprt,xdbval,dvfs)
        enddo
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Check the redox species in the strict basis set. Set the
c     appropriate flags.
c
      if (ns .eq. nsb) then
        qelect = uspec(ns)(1:3).eq.'e- '
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     If the strict basis redox species is e-, change it to O2(g).
c
      if (ns .eq. nsb) then
        if (qelect) then
          uspec(ns) = 'O2(g)'
          ncts = 1
          uessi(1) = 'O'
          cessi(1) = 2
          zchar(ns) = 0.
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     If the reaction is written in terms of e-, rewrite it in terms
c     of O2(g).
c
      if (qelect) then
        if (ns .gt. nsb) then
          call etoo2(cdrsi,dhfe,dhfs,dvfe,dvfs,ipch,ipchmx,ipcv,
     $    ipcvmx,narxmx,narxt,nbtmx1,ndrsts,ns,ntprmx,ntprt,udrsi,
     $    xhfe,xhfs,xlke,xlks,xvfe,xvfs)
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Process the species data.
c
      mwtss = 0.
      qnofes = .false.
      do n = 1,ncts
c
c       Search for element name in the uelem array.
c
        ux8 = uessi(n)(1:8)
        if (ux8(1:7) .ne. '<blank>') then
c
          do nc = 1,nct
            if (ux8(1:8) .eq. uelem(nc)(1:8)) then
              cess(nc,ns) = cess(nc,ns) + cessi(n)
              mwtss = mwtss + atwt(nc)*cessi(n)
              go to 220
            endif
          enddo
c
c         Error, not found.
c
          if (ns .gt. nsb) then
            j2 = ilnobl(uspec(ns))
            j3 = ilnobl(ux8)
            write (noutpt,1760) ux8(1:j3),uspec(ns)(1:j2)
            write (nttyo,1760) ux8(1:j3),uspec(ns)(1:j2)
 1760       format(/' * Error - (EQPT/pcraq) Unrecognized chemical',
     $      ' element "',a,'" is listed',/7x,'in the composition of',
     $      ' the species ',a,'.')
            nerr = nerr + 1
            qnofes = .true.
          endif
        endif
  220   continue
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      write (ndata1) uspec(ns),ncts,ndrsts
      write (ndat1f,1800) uspec(ns),ncts,ndrsts
 1800 format(a24,2x,2i5)
c
      write (ndata1) mwtss,zchar(ns)
      write (ndat1f,1810) mwtss,zchar(ns)
 1810 format(5x,f10.3,f5.0)
c
      if (ncts .gt. 0) then
        write (ndata1) (cessi(n),uessi(n), n = 1,ncts)
        n = 1
  230   continue
        if (n .eq. ncts) then
          j4 = ilnobl(uessi(n))
          write (ndat1f,1820) cessi(n),uessi(n)(1:j4)
 1820     format(1x,f10.4,2x,a)
          n = n + 1
        else
          j4 = ilnobl(uessi(n + 1))
          write (ndat1f,1830) cessi(n),uessi(n),
     $    cessi(n + 1),uessi(n + 1)(1:j4)
 1830     format(1x,f10.4,2x,a8,1x,f10.4,2x,a)
          n = n + 2
        endif
        if (n .le. ncts) go to 230
      endif
c
      if (ns .le. nsb) go to 270
c
      write (ndata1) (cdrsi(n),udrsi(n), n = 1,ndrsts)
      n = 1
c
  240 continue
      if (n .eq. ndrsts) then
        j4 = ilnobl(udrsi(n))
        write (ndat1f,1860) cdrsi(n),udrsi(n)(1:j4)
 1860   format(1x,f10.4,2x,a)
        n = n + 1
      else
        j4 = ilnobl(udrsi(n + 1))
        write (ndat1f,1870) cdrsi(n),udrsi(n),
     $  cdrsi(n + 1),udrsi(n + 1)(1:j4)
 1870   format(1x,f10.4,2x,a24,1x,f10.4,2x,a)
        n = n + 2
      endif
      if (n .le. ndrsts) go to 240
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
      qnofrs = .false.
      cdrs(nbt1,ns) = cdrsi(1)
      do n = 2,ndrsts
c
c       Search for species name in the uspec array.
c
        ux24 = udrsi(n)
        if (ux24(1:7) .ne. '<blank>') then
c
          do nse = 1,nbt
            if (ux24 .eq. uspec(nse)) then
              cdrs(nse,ns) = cdrs(nse,ns) + cdrsi(n)
              go to 250
            endif
          enddo
c
c         Error, not found.
c
          j2 = ilnobl(uspec(ns))
          j3 = ilnobl(ux24)
          write (noutpt,1880) uspec(ns)(1:j2),ux24(1:j3)
          write (nttyo,1880) uspec(ns)(1:j2),ux24(1:j3)
 1880     format(/' * Error - (EQPT/pcraq) The reaction which destroys',
     $    /7x,'non-basis species ',a,' is written in terms of an',
     $     /7x,'unrecognized basis species "',a,'".')
          nerr = nerr + 1
          qnofrs = .true.
  250     continue
        endif
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Test the reaction for mass and charge balance.
c     Skip if there are already obvious problems.
c
      if (ndrsts .ge. 2) then
        if (.not.qblkes .and. .not.qnofes) then
          if (.not.qblkrs .and. .not.qnofrs) then
            call rxnchk(cdrs,cess,mtotr,nbt,nbtmx1,nbtmx2,nco,
     $      nct,nctmax,nerr,noutpt,ns,nsb,nttyo,uelem,uspec,zchar)
          endif
        endif
      endif
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Fit interpolating polynomials to the log K grid.
c
      do ntpr = 1,ntprt
        do n = 1,narxt(ntpr)
          avgrid(n,ntpr) = xlks(n,ntpr,ns)
        enddo
      enddo
c
      call intrp(aamatr,apr,avgrid,cof,eps100,gmmatr,ipivot,
     $ narxmx,narxt,noutpt,ntprmx,ntprt,nttyo,tempc,tempcs,tmpcmx,
     $ xvec,yvec)
c
      ux24 = 'Log K'
      j2 = ilnobl(ux24)
      write (ndata1) ux24
      write (ndat1f,1010) ux24(1:j2)
c
      do ntpr = 1,ntprt
        nt = narxt(ntpr)
        write (ndata1) (apr(i,ntpr), i = 1,nt)
        write (ndat1f,1890) (apr(i,ntpr), i = 1,nt)
 1890   format( 5(1pe16.9) )
      enddo
c
  270 continue
c
      if (ipch .ge. 0) then
c
c       Fit interpolating polynomials to the enthalpy function grid.
c
        do ntpr = 1,ntprt
          do n = 1,narxt(ntpr)
            avgrid(n,ntpr) = xhfs(n,ntpr,ns)
          enddo
        enddo
c
        call intrp(aamatr,apr,avgrid,cof,eps100,gmmatr,ipivot,
     $  narxmx,narxt,noutpt,ntprmx,ntprt,nttyo,tempc,tempcs,tmpcmx,
     $  xvec,yvec)
c
        ux24 = 'Enthalpy'
        j2 = ilnobl(ux24)
        write (ndata1) ux24
        write (ndat1f,1010) ux24(1:j2)
c
        do ntpr = 1,ntprt
          nt = narxt(ntpr)
          write (ndata1) (apr(i,ntpr), i = 1,nt)
          write (ndat1f,1890) (apr(i,ntpr), i = 1,nt)
        enddo
c
c       Fit interpolating polynomials to the grids for its
c       pressure derivatives.
c
        do ipc = 1,ipch
c
          do ntpr = 1,ntprt
            do n = 1,narxt(ntpr)
              avgrid(n,ntpr) = dhfs(n,ntpr,ipc,ns)
            enddo
          enddo
c
          call intrp(aamatr,apr,avgrid,cof,eps100,gmmatr,ipivot,
     $    narxmx,narxt,noutpt,ntprmx,ntprt,nttyo,tempc,tempcs,tmpcmx,
     $    xvec,yvec)
c
          ux24 = 'dhfs( )'
          write (ux24(6:6),'(i1)') ipc
          j2 = ilnobl(ux24)
          write (ndata1) ux24
          write (ndat1f,1010) ux24(1:j2)
c
          do ntpr = 1,ntprt
            nt = narxt(ntpr)
            write (ndata1) (apr(i,ntpr), i = 1,nt)
            write (ndat1f,1890) (apr(i,ntpr), i = 1,nt)
          enddo
        enddo
      endif
c
      if (ipcv .ge. 0) then
c
c       Fit interpolating polynomials to the volume function grid.
c
        do ntpr = 1,ntprt
          do n = 1,narxt(ntpr)
            avgrid(n,ntpr) = xvfs(n,ntpr,ns)
          enddo
        enddo
c
        call intrp(aamatr,apr,avgrid,cof,eps100,gmmatr,ipivot,
     $  narxmx,narxt,noutpt,ntprmx,ntprt,nttyo,tempc,tempcs,tmpcmx,
     $  xvec,yvec)
c
        ux24 = 'Volume'
        j2 = ilnobl(ux24)
        write (ndata1) ux24
        write (ndat1f,1010) ux24(1:j2)
c
        do ntpr = 1,ntprt
          nt = narxt(ntpr)
          write (ndata1) (apr(i,ntpr), i = 1,nt)
          write (ndat1f,1890) (apr(i,ntpr), i = 1,nt)
        enddo
c
c       Fit interpolating polynomials to the grids for its
c       pressure derivatives.
c
        do ipc = 1,ipcv
c
          do ntpr = 1,ntprt
            do n = 1,narxt(ntpr)
              avgrid(n,ntpr) = dvfs(n,ntpr,ipc,ns)
            enddo
          enddo
c
          call intrp(aamatr,apr,avgrid,cof,eps100,gmmatr,ipivot,
     $    narxmx,narxt,noutpt,ntprmx,ntprt,nttyo,tempc,tempcs,tmpcmx,
     $    xvec,yvec)
c
          ux24 = 'dvfs( )'
          write (ux24(6:6),'(i1)') ipc
          j2 = ilnobl(ux24)
          write (ndata1) ux24
          write (ndat1f,1010) ux24(1:j2)
c
          do ntpr = 1,ntprt
            nt = narxt(ntpr)
            write (ndata1) (apr(i,ntpr), i = 1,nt)
            write (ndat1f,1890) (apr(i,ntpr), i = 1,nt)
          enddo
        enddo
      endif
c
      write (ndat1f,1010) utermc(1:72)
c
c     Look for another species block or terminator line.
c
      read (ndat0s,1000,end=990,err=995) uline
      nn = nn + 1
      go to 100
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  990 write (noutpt,2000)
      write (nttyo,2000)
 2000 format(/' * Error - (EQPT/pcraq) Unexpectedly encountered',
     $ /7x,'end-of-file while reading the DATA0 file.')
c
      write (noutpt,2010) nn
      write (nttyo,2010) nn
 2010 format(7x,'The value of the species block counter is ',i3,'.')
      if (ns .gt. 0) then
        j2 = ilnobl(uspec(ns))
        if (j2 .gt. 0) then
          write (noutpt,2020) uspec(ns)(1:j2)
          write (nttyo,2020) uspec(ns)(1:j2)
 2020     format(7x,'The last species name read was "',a,'".')
        else
          nsm1 = ns - 1
          if ((nsm1) .gt. 0) then
            j2 = ilnobl(uspec(nsm1))
            if (j2 .gt. 0) then
              write (noutpt,2020) uspec(nsm1)(1:j2)
              write (nttyo,2020) uspec(nsm1)(1:j2)
            endif
          endif
        endif
      endif
      j2 = ilnobl(uline)
      if (j2 .gt. 0) then
        j2 = min(j2,70)
        write (noutpt,2030) uline(1:j2)
        write (nttyo,2030) uline(1:j2)
 2030   format(7x,'The last line read was the following:',
     $  /7x,'"',a,'"')
      endif
      stop
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  995 write (noutpt,2040)
      write (nttyo,2040)
 2040 format(/' * Error - (EQPT/pcraq) Encountered a read format',
     $ /7x,'error while reading the DATA0 file.')
c
      write (noutpt,2010) nn
      write (nttyo,2010) nn
      if (ns .gt. 0) then
        j2 = ilnobl(uspec(ns))
        if (j2 .gt. 0) then
          write (noutpt,2020) uspec(ns)(1:j2)
          write (nttyo,2020) uspec(ns)(1:j2)
        else
          nsm1 = ns - 1
          if ((nsm1) .gt. 0) then
            j2 = ilnobl(uspec(nsm1))
            if (j2 .gt. 0) then
              write (noutpt,2020) uspec(nsm1)(1:j2)
              write (nttyo,2020) uspec(nsm1)(1:j2)
            endif
          endif
        endif
      endif
      j2 = ilnobl(uline)
      if (j2 .gt. 0) then
        j2 = min(j2,67)
        write (noutpt,2030) uline(1:j2)
        write (nttyo,2030) uline(1:j2)
      endif
      stop
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
  999 continue
      end


SUBROUTINE pbj(g,bit,its)

!-------------------------------------------------------------
!
!  Parallel Block Jacobi
!
!  Use the scalar flux solution to check for convergence
!  If not converged, move to next iteration by passing angular
!   flux moments to neighbors. Neighbors store in psi* vectors
!  If not converged and out of iterations, store everything
!   and exit this group
!  If converged, store everything and move to next group
!
!-------------------------------------------------------------

USE invar
USE solvar
USE timevar
IMPLICIT NONE
INTEGER, INTENT(IN) :: g, bit, its
INTEGER :: i, j, k, itsm
INTEGER :: myztag, myytag, myxtag, znxt, zprv, ynxt, yprv, xnxt, xprv
INTEGER :: znxtag, zprtag, ynxtag, yprtag, xnxtag, xprtag, neqz, neqy, neqx, ieq, ierr
INTEGER, DIMENSION(3) :: istat
REAL*8 :: df, dfmx

INCLUDE 'mpif.h'

! Set up some tags
myztag = 100 + zrank
myytag = 100 + yrank
myxtag = 100 + xrank
znxt = zrank + 1
znxtag = 100 + znxt
zprv = zrank - 1
zprtag = 100 + zprv
ynxt = yrank + 1
ynxtag = 100 + ynxt
yprv = yrank - 1
yprtag = 100 + yprv
xnxt = xrank + 1
xnxtag = 100 + xnxt
xprv = xrank - 1
xprtag = 100 + xprv

! Check convergence of scalar flux depending on the method
! Each process checks its own fluxes, then perform MPI Reduction
IF (meth == 0) THEN
   IF (MINVAL(ABS(fold(:,:,:))) >= tolr) THEN
      df = MAXVAL(ABS((f(:,:,:,g)-fold(:,:,:))/fold(:,:,:)))
   ELSE
      df = MAXVAL(ABS(f(:,:,:,g) - fold(:,:,:)))
   END IF
ELSE
   IF (MINVAL(ABS(phiold)) >= tolr) THEN
      df = MAXVAL(ABS((phi(:,g) - phiold)/phiold))
   ELSE
      df = MAXVAL(ABS(phi(:,g) - phiold))
   END IF
END IF

IF (isize == 1) THEN
   IF (bc(1)/=1 .AND. bc(2)/=1 .AND. bc(3)/=1 .AND. bc(4)/=1 .AND. bc(5)/=1 .AND. bc(6)/=1) THEN
      df = 0.0
   END IF
END IF

! Get the overall max difference
CALL MPI_ALLREDUCE(df,dfmx,1,MPI_DOUBLE_PRECISION,MPI_MAX,allcomm,ierr)

! Only get the max number of SI/CG iterations from sub-domains if requested
IF (itp == 1) THEN
   CALL MPI_REDUCE(its,itsm,1,MPI_INTEGER,MPI_MAX,0,allcomm,ierr)
END IF

!IF (dfmx > err .AND. bit < bitmx) THEN
   ! Only print iteration information if requested
   IF (irank == root) THEN
      IF (itp == 1) WRITE(8,111) g, bit, dfmx, itsm
   END IF
   ! Set the previous iterate of the flux equal to the current
   IF (meth == 0) THEN
      fold = f(:,:,:,g)
   ELSE
      phiold = phi(:,g)
   END IF
   ! Send psio to neighbors. Inner blocks have 24 communications (8 octants to
   ! 3 neigbors each). Then set the incoming data into psii

   ! Perform the sends 'up z'
   neqz = apo*xys
   ! Octant 1
   IF (zrank /= npz-1) CALL MPI_SEND(psio(1,1,g),neqz,MPI_DOUBLE_PRECISION,znxt,znxtag,zcomm,ierr)
   IF (zrank /= 0) CALL MPI_RECV(psii(1,1),neqz,MPI_DOUBLE_PRECISION,zprv,myztag,zcomm,istat,ierr)
   ! Octant 2
   IF (zrank /= npz-1) CALL MPI_SEND(psio(1,2,g),neqz,MPI_DOUBLE_PRECISION,znxt,znxtag,zcomm,ierr)
   IF (zrank /= 0) CALL MPI_RECV(psii(1,2),neqz,MPI_DOUBLE_PRECISION,zprv,myztag,zcomm,istat,ierr)
   ! Octant 3
   IF (zrank /= npz-1) CALL MPI_SEND(psio(1,3,g),neqz,MPI_DOUBLE_PRECISION,znxt,znxtag,zcomm,ierr)
   IF (zrank /= 0) CALL MPI_RECV(psii(1,3),neqz,MPI_DOUBLE_PRECISION,zprv,myztag,zcomm,istat,ierr)
   ! Octant 4
   IF (zrank /= npz-1) CALL MPI_SEND(psio(1,4,g),neqz,MPI_DOUBLE_PRECISION,znxt,znxtag,zcomm,ierr)
   IF (zrank /= 0) CALL MPI_RECV(psii(1,4),neqz,MPI_DOUBLE_PRECISION,zprv,myztag,zcomm,istat,ierr)

   ! Perform the sends 'down z'
   ! Octant 5
   IF (zrank /= 0) CALL MPI_SEND(psio(1,5,g),neqz,MPI_DOUBLE_PRECISION,zprv,zprtag,zcomm,ierr)
   IF (zrank /= npz-1) CALL MPI_RECV(psii(1,5),neqz,MPI_DOUBLE_PRECISION,znxt,myztag,zcomm,istat,ierr)
   ! Octant 6
   IF (zrank /= 0) CALL MPI_SEND(psio(1,6,g),neqz,MPI_DOUBLE_PRECISION,zprv,zprtag,zcomm,ierr)
   IF (zrank /= npz-1) CALL MPI_RECV(psii(1,6),neqz,MPI_DOUBLE_PRECISION,znxt,myztag,zcomm,istat,ierr)
   ! Octant 7
   IF (zrank /= 0) CALL MPI_SEND(psio(1,7,g),neqz,MPI_DOUBLE_PRECISION,zprv,zprtag,zcomm,ierr)
   IF (zrank /= npz-1) CALL MPI_RECV(psii(1,7),neqz,MPI_DOUBLE_PRECISION,znxt,myztag,zcomm,istat,ierr)
   ! Octant 8
   IF (zrank /= 0) CALL MPI_SEND(psio(1,8,g),neqz,MPI_DOUBLE_PRECISION,zprv,zprtag,zcomm,ierr)
   IF (zrank /= npz-1) CALL MPI_RECV(psii(1,8),neqz,MPI_DOUBLE_PRECISION,znxt,myztag,zcomm,istat,ierr)

   ! Update for reflective boundary conditions at zrank = 0 and npz-1. Only
   ! apply new boundary conditions to those on the z-face for each incoming octant
   IF (zrank == 0 .AND. bc(1) == 1) THEN         ! Reflective at low-z
      psii(1:neqz,1) = psio(1:neqz,5,g)
      psii(1:neqz,2) = psio(1:neqz,6,g)
      psii(1:neqz,3) = psio(1:neqz,7,g)
      psii(1:neqz,4) = psio(1:neqz,8,g)
   END IF
   IF (zrank == npz-1 .AND. bc(2) == 1) THEN     ! Reflective at high-z
      psii(1:neqz,5) = psio(1:neqz,1,g)
      psii(1:neqz,6) = psio(1:neqz,2,g)
      psii(1:neqz,7) = psio(1:neqz,3,g)
      psii(1:neqz,8) = psio(1:neqz,4,g)
   END IF

   ! Perform the sends 'up y'
   ieq = neqz + 1
   neqy = apo*xzs
   ! Quadrant 1
   IF (yrank /= npy-1) CALL MPI_SEND(psio(ieq,1,g),neqy,MPI_DOUBLE_PRECISION,ynxt,ynxtag,ycomm,ierr)
   IF (yrank /= 0) CALL MPI_RECV(psii(ieq,1),neqy,MPI_DOUBLE_PRECISION,yprv,myytag,ycomm,istat,ierr)
   ! Quadrant 2
   IF (yrank /= npy-1) CALL MPI_SEND(psio(ieq,2,g),neqy,MPI_DOUBLE_PRECISION,ynxt,ynxtag,ycomm,ierr)
   IF (yrank /= 0) CALL MPI_RECV(psii(ieq,2),neqy,MPI_DOUBLE_PRECISION,yprv,myytag,ycomm,istat,ierr)
   ! Quadrant 5
   IF (yrank /= npy-1) CALL MPI_SEND(psio(ieq,5,g),neqy,MPI_DOUBLE_PRECISION,ynxt,ynxtag,ycomm,ierr)
   IF (yrank /= 0) CALL MPI_RECV(psii(ieq,5),neqy,MPI_DOUBLE_PRECISION,yprv,myytag,ycomm,istat,ierr)
   ! Quadrant 6
   IF (yrank /= npy-1) CALL MPI_SEND(psio(ieq,6,g),neqy,MPI_DOUBLE_PRECISION,ynxt,ynxtag,ycomm,ierr)
   IF (yrank /= 0) CALL MPI_RECV(psii(ieq,6),neqy,MPI_DOUBLE_PRECISION,yprv,myytag,ycomm,istat,ierr)

   ! Perform the sends 'down y'
   ! Quadrant 3
   IF (yrank /= 0) CALL MPI_SEND(psio(ieq,3,g),neqy,MPI_DOUBLE_PRECISION,yprv,yprtag,ycomm,ierr)
   IF (yrank /= npy-1) CALL MPI_RECV(psii(ieq,3),neqy,MPI_DOUBLE_PRECISION,ynxt,myytag,ycomm,istat,ierr)
   ! Quadrant 4
   IF (yrank /= 0) CALL MPI_SEND(psio(ieq,4,g),neqy,MPI_DOUBLE_PRECISION,yprv,yprtag,ycomm,ierr)
   IF (yrank /= npy-1) CALL MPI_RECV(psii(ieq,4),neqy,MPI_DOUBLE_PRECISION,ynxt,myytag,ycomm,istat,ierr)
   ! Quadrant 7
   IF (yrank /= 0) CALL MPI_SEND(psio(ieq,7,g),neqy,MPI_DOUBLE_PRECISION,yprv,yprtag,ycomm,ierr)
   IF (yrank /= npy-1) CALL MPI_RECV(psii(ieq,7),neqy,MPI_DOUBLE_PRECISION,ynxt,myytag,ycomm,istat,ierr)
   ! Quadrant 8
   IF (yrank /= 0) CALL MPI_SEND(psio(ieq,8,g),neqy,MPI_DOUBLE_PRECISION,yprv,yprtag,ycomm,ierr)
   IF (yrank /= npy-1) CALL MPI_RECV(psii(ieq,8),neqy,MPI_DOUBLE_PRECISION,ynxt,myytag,ycomm,istat,ierr)

   ! Update for reflective boundary conditions at yrank = 0 and npy-1. Only
   ! apply new boundary conditions to those on the y-face for each incoming octant
   IF (yrank == 0 .AND. bc(3) == 1) THEN         ! Reflective at low-y
      psii(ieq:(neqz+neqy),1) = psio(ieq:(neqz+neqy),4,g)
      psii(ieq:(neqz+neqy),2) = psio(ieq:(neqz+neqy),3,g)
      psii(ieq:(neqz+neqy),5) = psio(ieq:(neqz+neqy),8,g)
      psii(ieq:(neqz+neqy),6) = psio(ieq:(neqz+neqy),7,g)
   END IF
   IF (yrank == npy-1 .AND. bc(4) == 1) THEN     ! Reflective at high-y
      psii(ieq:(neqz+neqy),4) = psio(ieq:(neqz+neqy),1,g)
      psii(ieq:(neqz+neqy),3) = psio(ieq:(neqz+neqy),2,g)
      psii(ieq:(neqz+neqy),8) = psio(ieq:(neqz+neqy),5,g)
      psii(ieq:(neqz+neqy),7) = psio(ieq:(neqz+neqy),6,g)
   END IF

   ! Perform the sends 'up x'
   ieq = ieq + neqy
   neqx = apo*yzs
   ! Quadrant 1
   IF (xrank /= npx-1) CALL MPI_SEND(psio(ieq,1,g),neqx,MPI_DOUBLE_PRECISION,xnxt,xnxtag,xcomm,ierr)
   IF (xrank /= 0) CALL MPI_RECV(psii(ieq,1),neqx,MPI_DOUBLE_PRECISION,xprv,myxtag,xcomm,istat,ierr)
   ! Quadrant 4
   IF (xrank /= npx-1) CALL MPI_SEND(psio(ieq,4,g),neqx,MPI_DOUBLE_PRECISION,xnxt,xnxtag,xcomm,ierr)
   IF (xrank /= 0) CALL MPI_RECV(psii(ieq,4),neqx,MPI_DOUBLE_PRECISION,xprv,myxtag,xcomm,istat,ierr)
   ! Quadrant 5
   IF (xrank /= npx-1) CALL MPI_SEND(psio(ieq,5,g),neqx,MPI_DOUBLE_PRECISION,xnxt,xnxtag,xcomm,ierr)
   IF (xrank /= 0) CALL MPI_RECV(psii(ieq,5),neqx,MPI_DOUBLE_PRECISION,xprv,myxtag,xcomm,istat,ierr)
   ! Quadrant 8
   IF (xrank /= npx-1) CALL MPI_SEND(psio(ieq,8,g),neqx,MPI_DOUBLE_PRECISION,xnxt,xnxtag,xcomm,ierr)
   IF (xrank /= 0) CALL MPI_RECV(psii(ieq,8),neqx,MPI_DOUBLE_PRECISION,xprv,myxtag,xcomm,istat,ierr)

   ! Perform the sends 'down x'
   ! Quadrant 2
   IF (xrank /= 0) CALL MPI_SEND(psio(ieq,2,g),neqx,MPI_DOUBLE_PRECISION,xprv,xprtag,xcomm,ierr)
   IF (xrank /= npx-1) CALL MPI_RECV(psii(ieq,2),neqx,MPI_DOUBLE_PRECISION,xnxt,myxtag,xcomm,istat,ierr)
   ! Quadrant 3
   IF (xrank /= 0) CALL MPI_SEND(psio(ieq,3,g),neqx,MPI_DOUBLE_PRECISION,xprv,xprtag,xcomm,ierr)
   IF (xrank /= npx-1) CALL MPI_RECV(psii(ieq,3),neqx,MPI_DOUBLE_PRECISION,xnxt,myxtag,xcomm,istat,ierr)
   ! Quadrant 6
   IF (xrank /= 0) CALL MPI_SEND(psio(ieq,6,g),neqx,MPI_DOUBLE_PRECISION,xprv,xprtag,xcomm,ierr)
   IF (xrank /= npx-1) CALL MPI_RECV(psii(ieq,6),neqx,MPI_DOUBLE_PRECISION,xnxt,myxtag,xcomm,istat,ierr)
   ! Quadrant 7
   IF (xrank /= 0) CALL MPI_SEND(psio(ieq,7,g),neqx,MPI_DOUBLE_PRECISION,xprv,xprtag,xcomm,ierr)
   IF (xrank /= npx-1) CALL MPI_RECV(psii(ieq,7),neqx,MPI_DOUBLE_PRECISION,xnxt,myxtag,xcomm,istat,ierr)

   ! Update for reflective boundary conditions at xrank = 0 and npx-1. Only
   ! apply new boundary conditions to those on the x-face for each incoming octant
   IF (xrank == 0 .AND. bc(5) == 1) THEN         ! Reflective at low-x
      psii(ieq:(neqz+neqy+neqx),1) = psio(ieq:(neqz+neqy+neqx),2,g)
      psii(ieq:(neqz+neqy+neqx),4) = psio(ieq:(neqz+neqy+neqx),3,g)
      psii(ieq:(neqz+neqy+neqx),5) = psio(ieq:(neqz+neqy+neqx),6,g)
      psii(ieq:(neqz+neqy+neqx),8) = psio(ieq:(neqz+neqy+neqx),7,g)
   END IF
   IF (xrank == npx-1 .AND. bc(6) == 1) THEN     ! Reflective at high-x
      psii(ieq:(neqz+neqy+neqx),2) = psio(ieq:(neqz+neqy+neqx),1,g)
      psii(ieq:(neqz+neqy+neqx),3) = psio(ieq:(neqz+neqy+neqx),4,g)
      psii(ieq:(neqz+neqy+neqx),6) = psio(ieq:(neqz+neqy+neqx),5,g)
      psii(ieq:(neqz+neqy+neqx),7) = psio(ieq:(neqz+neqy+neqx),8,g)
   END IF

!ELSE IF (dfmx < err) THEN
IF (dfmx < err) THEN
   bcnvf(g) = 1
   CALL CPU_TIME(tsolve)
   IF (irank == root) THEN
      WRITE(8,'(2X,A,I3,A,I5,A,ES11.3,/)') "Group ", g, " converged in ", bit, " iterations. Max error = ", dfmx
      IF (itp == 1 .AND. isize == 1) THEN
         IF (meth == 0) WRITE(8,'(2X,A,I5,A)') "Serial SI run used ", its, " iterations"
         IF (meth == 1 .AND. idos == 1) WRITE(8,'(2X,A,I5,A)') "Serial ITM-CG run used ", its, " iterations"
         IF (meth == 1 .AND. idos == 2) WRITE(8,'(2X,A,I5,A)') "Serial ITM-SOR run used ", its, " iterations"
      END IF
  END IF
ELSE IF (bit == bitmx) THEN
   bcnvf(g) = 0
   CALL CPU_TIME(tsolve)
   IF (irank == root) THEN
      WRITE (8,'(/,2X,A,I2,A,ES11.3)') "ERROR: Group ", g, " did not converge. Max error= ", dfmx
      WRITE (8,*) "Will adversely affect other results. Aborting program."
   END IF
END IF

111 FORMAT(2X,'Gr',I3,' It ', I5,' Dfmx ', ES11.3,' SI/CG Its ', I5)

RETURN
END SUBROUTINE pbj