MODULE traldf_triad
  USE oce
  USE dom_oce
  USE phycst
  USE trc_oce
  USE zdf_oce
  USE ldftra
  USE ldfslp
  USE traldf_iso
  USE diaptr
  USE diaar5
  USE zpshde
  USE in_out_manager
  USE iom
  USE lbclnk
  USE lib_mpp
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: tra_ldf_triad
  REAL(KIND = wp), DIMENSION(:, :, :), ALLOCATABLE, SAVE :: zdkt3d
  LOGICAL :: l_ptr
  LOGICAL :: l_hst
  CONTAINS
  SUBROUTINE tra_ldf_triad(kt, kit000, cdtype, pahu, pahv, pgu, pgv, pgui, pgvi, ptb, ptbb, pta, kjpt, kpass)
    INTEGER, INTENT(IN   ) :: kt
    INTEGER, INTENT(IN   ) :: kit000
    CHARACTER(LEN = 3), INTENT(IN   ) :: cdtype
    INTEGER, INTENT(IN   ) :: kjpt
    INTEGER, INTENT(IN   ) :: kpass
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk), INTENT(IN   ) :: pahu, pahv
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt), INTENT(IN   ) :: pgu, pgv
    REAL(KIND = wp), DIMENSION(jpi, jpj, kjpt), INTENT(IN   ) :: pgui, pgvi
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptb
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(IN   ) :: ptbb
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk, kjpt), INTENT(INOUT) :: pta
    INTEGER :: ji, jj, jk, jn
    INTEGER :: ip, jp, kp
    INTEGER :: ierr
    REAL(KIND = wp) :: zmsku, zabe1, zcof1, zcoef3
    REAL(KIND = wp) :: zmskv, zabe2, zcof2, zcoef4
    REAL(KIND = wp) :: zcoef0, ze3w_2, zsign, z2dt, z1_2dt
    REAL(KIND = wp) :: zslope_skew, zslope_iso, zslope2, zbu, zbv
    REAL(KIND = wp) :: ze1ur, ze2vr, ze3wr, zdxt, zdyt, zdzt
    REAL(KIND = wp) :: zah, zah_slp, zaei_slp
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: z2d
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdit, zdjt, zftu, zftv, ztfw, zpsi_uw, zpsi_vw
    IF (.NOT. ALLOCATED(zdkt3d)) THEN
      ALLOCATE(zdkt3d(jpi, jpj, 0 : 1), STAT = ierr)
      IF (lk_mpp) CALL mpp_sum(ierr)
      IF (ierr > 0) CALL ctl_stop('STOP', 'tra_ldf_triad: unable to allocate arrays')
    END IF
    IF (kpass == 1 .AND. kt == kit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'tra_ldf_triad : rotated laplacian diffusion operator on ', cdtype
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~~~~~~~'
    END IF
    l_hst = .FALSE.
    l_ptr = .FALSE.
    IF (cdtype == 'TRA' .AND. ln_diaptr) l_ptr = .TRUE.
    IF (cdtype == 'TRA' .AND. (iom_use("uadv_heattr") .OR. iom_use("vadv_heattr") .OR. iom_use("uadv_salttr") .OR. iom_use("vadv_salttr"))) l_hst = .TRUE.
    IF (neuler == 0 .AND. kt == kit000) THEN
      z2dt = rdt
    ELSE
      z2dt = 2. * rdt
    END IF
    z1_2dt = 1._wp / z2dt
    IF (kpass == 1) THEN
      zsign = 1._wp
    ELSE
      zsign = - 1._wp
    END IF
    IF (kpass == 1) THEN
      !$ACC KERNELS
      akz(:, :, :) = 0._wp
      ah_wslp2(:, :, :) = 0._wp
      !$ACC END KERNELS
      IF (ln_ldfeiv_dia) THEN
        !$ACC KERNELS
        zpsi_uw(:, :, :) = 0._wp
        zpsi_vw(:, :, :) = 0._wp
        !$ACC END KERNELS
      END IF
      !$ACC KERNELS
      DO ip = 0, 1
        DO kp = 0, 1
          DO jk = 1, jpkm1
            DO jj = 1, jpjm1
              DO ji = 1, jpim1
                ze3wr = 1._wp / e3w_n(ji + ip, jj, jk + kp)
                zbu = e1e2u(ji, jj) * e3u_n(ji, jj, jk)
                zah = 0.25_wp * pahu(ji, jj, jk)
                zslope_skew = triadi_g(ji + ip, jj, jk, 1 - ip, kp)
                zslope2 = zslope_skew + (gdept_n(ji + 1, jj, jk) - gdept_n(ji, jj, jk)) * r1_e1u(ji, jj) * umask(ji, jj, jk + kp)
                zslope2 = zslope2 * zslope2
                ah_wslp2(ji + ip, jj, jk + kp) = ah_wslp2(ji + ip, jj, jk + kp) + zah * zbu * ze3wr * r1_e1e2t(ji + ip, jj) * zslope2
                akz(ji + ip, jj, jk + kp) = akz(ji + ip, jj, jk + kp) + zah * r1_e1u(ji, jj) * r1_e1u(ji, jj) * umask(ji, jj, jk + kp)
                IF (ln_ldfeiv_dia) zpsi_uw(ji, jj, jk + kp) = zpsi_uw(ji, jj, jk + kp) + 0.25_wp * aeiu(ji, jj, jk) * e2u(ji, jj) * zslope_skew
              END DO
            END DO
          END DO
        END DO
      END DO
      DO jp = 0, 1
        DO kp = 0, 1
          DO jk = 1, jpkm1
            DO jj = 1, jpjm1
              DO ji = 1, jpim1
                ze3wr = 1.0_wp / e3w_n(ji, jj + jp, jk + kp)
                zbv = e1e2v(ji, jj) * e3v_n(ji, jj, jk)
                zah = 0.25_wp * pahv(ji, jj, jk)
                zslope_skew = triadj_g(ji, jj + jp, jk, 1 - jp, kp)
                zslope2 = zslope_skew + (gdept_n(ji, jj + 1, jk) - gdept_n(ji, jj, jk)) * r1_e2v(ji, jj) * vmask(ji, jj, jk + kp)
                zslope2 = zslope2 * zslope2
                ah_wslp2(ji, jj + jp, jk + kp) = ah_wslp2(ji, jj + jp, jk + kp) + zah * zbv * ze3wr * r1_e1e2t(ji, jj + jp) * zslope2
                akz(ji, jj + jp, jk + kp) = akz(ji, jj + jp, jk + kp) + zah * r1_e2v(ji, jj) * r1_e2v(ji, jj) * vmask(ji, jj, jk + kp)
                IF (ln_ldfeiv_dia) zpsi_vw(ji, jj, jk + kp) = zpsi_vw(ji, jj, jk + kp) + 0.25 * aeiv(ji, jj, jk) * e1v(ji, jj) * zslope_skew
              END DO
            END DO
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (ln_traldf_msc) THEN
        IF (ln_traldf_blp) THEN
          !$ACC KERNELS
          DO jk = 2, jpkm1
            DO jj = 1, jpjm1
              DO ji = 1, jpim1
                akz(ji, jj, jk) = 16._wp * ah_wslp2(ji, jj, jk) * (akz(ji, jj, jk) + ah_wslp2(ji, jj, jk) / (e3w_n(ji, jj, jk) * e3w_n(ji, jj, jk)))
              END DO
            END DO
          END DO
          !$ACC END KERNELS
        ELSE IF (ln_traldf_lap) THEN
          !$ACC KERNELS
          DO jk = 2, jpkm1
            DO jj = 1, jpjm1
              DO ji = 1, jpim1
                ze3w_2 = e3w_n(ji, jj, jk) * e3w_n(ji, jj, jk)
                zcoef0 = z2dt * (akz(ji, jj, jk) + ah_wslp2(ji, jj, jk) / ze3w_2)
                akz(ji, jj, jk) = MAX(zcoef0 - 0.5_wp, 0._wp) * ze3w_2 * z1_2dt
              END DO
            END DO
          END DO
          !$ACC END KERNELS
        END IF
      ELSE
        !$ACC KERNELS
        akz(:, :, :) = ah_wslp2(:, :, :)
        !$ACC END KERNELS
      END IF
      IF (ln_ldfeiv_dia .AND. cdtype == 'TRA') CALL ldf_eiv_dia(zpsi_uw, zpsi_vw)
    END IF
    DO jn = 1, kjpt
      !$ACC KERNELS
      ztfw(:, :, :) = 0._wp
      zftu(:, :, :) = 0._wp
      zftv(:, :, :) = 0._wp
      DO jk = 1, jpkm1
        DO jj = 1, jpjm1
          DO ji = 1, jpim1
            zdit(ji, jj, jk) = (ptb(ji + 1, jj, jk, jn) - ptb(ji, jj, jk, jn)) * umask(ji, jj, jk)
            zdjt(ji, jj, jk) = (ptb(ji, jj + 1, jk, jn) - ptb(ji, jj, jk, jn)) * vmask(ji, jj, jk)
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF (ln_zps .AND. l_grad_zps) THEN
        !$ACC KERNELS
        DO jj = 1, jpjm1
          DO ji = 1, jpim1
            zdit(ji, jj, mbku(ji, jj)) = pgu(ji, jj, jn)
            zdjt(ji, jj, mbkv(ji, jj)) = pgv(ji, jj, jn)
          END DO
        END DO
        !$ACC END KERNELS
        IF (ln_isfcav) THEN
          !$ACC KERNELS
          DO jj = 1, jpjm1
            DO ji = 1, jpim1
              IF (miku(ji, jj) > 1) zdit(ji, jj, miku(ji, jj)) = pgui(ji, jj, jn)
              IF (mikv(ji, jj) > 1) zdjt(ji, jj, mikv(ji, jj)) = pgvi(ji, jj, jn)
            END DO
          END DO
          !$ACC END KERNELS
        END IF
      END IF
      DO jk = 1, jpkm1
        !$ACC KERNELS
        zdkt3d(:, :, 1) = (ptb(:, :, jk, jn) - ptb(:, :, jk + 1, jn)) * tmask(:, :, jk + 1)
        !$ACC END KERNELS
        IF (jk == 1) THEN
          !$ACC KERNELS
          zdkt3d(:, :, 0) = zdkt3d(:, :, 1)
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          zdkt3d(:, :, 0) = (ptb(:, :, jk - 1, jn) - ptb(:, :, jk, jn)) * tmask(:, :, jk)
          !$ACC END KERNELS
        END IF
        zaei_slp = 0._wp
        IF (ln_botmix_triad) THEN
          !$ACC KERNELS
          DO ip = 0, 1
            DO kp = 0, 1
              DO jj = 1, jpjm1
                DO ji = 1, jpim1
                  ze1ur = r1_e1u(ji, jj)
                  zdxt = zdit(ji, jj, jk) * ze1ur
                  ze3wr = 1._wp / e3w_n(ji + ip, jj, jk + kp)
                  zdzt = zdkt3d(ji + ip, jj, kp) * ze3wr
                  zslope_skew = triadi_g(ji + ip, jj, jk, 1 - ip, kp)
                  zslope_iso = triadi(ji + ip, jj, jk, 1 - ip, kp)
                  zbu = 0.25_wp * e1e2u(ji, jj) * e3u_n(ji, jj, jk)
                  zah = pahu(ji, jj, jk)
                  zah_slp = zah * zslope_iso
                  IF (ln_ldfeiv) zaei_slp = aeiu(ji, jj, jk) * zslope_skew
                  zftu(ji, jj, jk) = zftu(ji, jj, jk) - (zah * zdxt + (zah_slp - zaei_slp) * zdzt) * zbu * ze1ur
                  ztfw(ji + ip, jj, jk + kp) = ztfw(ji + ip, jj, jk + kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr
                END DO
              END DO
            END DO
          END DO
          DO jp = 0, 1
            DO kp = 0, 1
              DO jj = 1, jpjm1
                DO ji = 1, jpim1
                  ze2vr = r1_e2v(ji, jj)
                  zdyt = zdjt(ji, jj, jk) * ze2vr
                  ze3wr = 1._wp / e3w_n(ji, jj + jp, jk + kp)
                  zdzt = zdkt3d(ji, jj + jp, kp) * ze3wr
                  zslope_skew = triadj_g(ji, jj + jp, jk, 1 - jp, kp)
                  zslope_iso = triadj(ji, jj + jp, jk, 1 - jp, kp)
                  zbv = 0.25_wp * e1e2v(ji, jj) * e3v_n(ji, jj, jk)
                  zah = pahv(ji, jj, jk)
                  zah_slp = zah * zslope_iso
                  IF (ln_ldfeiv) zaei_slp = aeiv(ji, jj, jk) * zslope_skew
                  zftv(ji, jj, jk) = zftv(ji, jj, jk) - (zah * zdyt + (zah_slp - zaei_slp) * zdzt) * zbv * ze2vr
                  ztfw(ji, jj + jp, jk + kp) = ztfw(ji, jj + jp, jk + kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr
                END DO
              END DO
            END DO
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO ip = 0, 1
            DO kp = 0, 1
              DO jj = 1, jpjm1
                DO ji = 1, jpim1
                  ze1ur = r1_e1u(ji, jj)
                  zdxt = zdit(ji, jj, jk) * ze1ur
                  ze3wr = 1._wp / e3w_n(ji + ip, jj, jk + kp)
                  zdzt = zdkt3d(ji + ip, jj, kp) * ze3wr
                  zslope_skew = triadi_g(ji + ip, jj, jk, 1 - ip, kp)
                  zslope_iso = triadi(ji + ip, jj, jk, 1 - ip, kp)
                  zbu = 0.25_wp * e1e2u(ji, jj) * e3u_n(ji, jj, jk)
                  zah = pahu(ji, jj, jk) * umask(ji, jj, jk + kp)
                  zah_slp = zah * zslope_iso
                  IF (ln_ldfeiv) zaei_slp = aeiu(ji, jj, jk) * zslope_skew
                  zftu(ji, jj, jk) = zftu(ji, jj, jk) - (zah * zdxt + (zah_slp - zaei_slp) * zdzt) * zbu * ze1ur
                  ztfw(ji + ip, jj, jk + kp) = ztfw(ji + ip, jj, jk + kp) - (zah_slp + zaei_slp) * zdxt * zbu * ze3wr
                END DO
              END DO
            END DO
          END DO
          DO jp = 0, 1
            DO kp = 0, 1
              DO jj = 1, jpjm1
                DO ji = 1, jpim1
                  ze2vr = r1_e2v(ji, jj)
                  zdyt = zdjt(ji, jj, jk) * ze2vr
                  ze3wr = 1._wp / e3w_n(ji, jj + jp, jk + kp)
                  zdzt = zdkt3d(ji, jj + jp, kp) * ze3wr
                  zslope_skew = triadj_g(ji, jj + jp, jk, 1 - jp, kp)
                  zslope_iso = triadj(ji, jj + jp, jk, 1 - jp, kp)
                  zbv = 0.25_wp * e1e2v(ji, jj) * e3v_n(ji, jj, jk)
                  zah = pahv(ji, jj, jk) * vmask(ji, jj, jk + kp)
                  zah_slp = zah * zslope_iso
                  IF (ln_ldfeiv) zaei_slp = aeiv(ji, jj, jk) * zslope_skew
                  zftv(ji, jj, jk) = zftv(ji, jj, jk) - (zah * zdyt + (zah_slp - zaei_slp) * zdzt) * zbv * ze2vr
                  ztfw(ji, jj + jp, jk + kp) = ztfw(ji, jj + jp, jk + kp) - (zah_slp + zaei_slp) * zdyt * zbv * ze3wr
                END DO
              END DO
            END DO
          END DO
          !$ACC END KERNELS
        END IF
        !$ACC KERNELS
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) + zsign * (zftu(ji - 1, jj, jk) - zftu(ji, jj, jk) + zftv(ji, jj - 1, jk) - zftv(ji, jj, jk)) / (e1e2t(ji, jj) * e3t_n(ji, jj, jk))
          END DO
        END DO
        !$ACC END KERNELS
      END DO
      IF (ln_traldf_lap) THEN
        !$ACC KERNELS
        DO jk = 2, jpkm1
          DO jj = 1, jpjm1
            DO ji = 2, jpim1
              ztfw(ji, jj, jk) = ztfw(ji, jj, jk) - e1e2t(ji, jj) / e3w_n(ji, jj, jk) * tmask(ji, jj, jk) * (ah_wslp2(ji, jj, jk) - akz(ji, jj, jk)) * (ptb(ji, jj, jk - 1, jn) - ptb(ji, jj, jk, jn))
            END DO
          END DO
        END DO
        !$ACC END KERNELS
      ELSE
        SELECT CASE (kpass)
        CASE (1)
          !$ACC KERNELS
          DO jk = 2, jpkm1
            DO jj = 1, jpjm1
              DO ji = 2, jpim1
                ztfw(ji, jj, jk) = ztfw(ji, jj, jk) - e1e2t(ji, jj) / e3w_n(ji, jj, jk) * tmask(ji, jj, jk) * ah_wslp2(ji, jj, jk) * (ptb(ji, jj, jk - 1, jn) - ptb(ji, jj, jk, jn))
              END DO
            END DO
          END DO
          !$ACC END KERNELS
        CASE (2)
          !$ACC KERNELS
          DO jk = 2, jpkm1
            DO jj = 1, jpjm1
              DO ji = 2, jpim1
                ztfw(ji, jj, jk) = ztfw(ji, jj, jk) - e1e2t(ji, jj) / e3w_n(ji, jj, jk) * tmask(ji, jj, jk) * (ah_wslp2(ji, jj, jk) * (ptb(ji, jj, jk - 1, jn) - ptb(ji, jj, jk, jn)) + akz(ji, jj, jk) * (ptbb(ji, jj, jk - 1, jn) - ptbb(ji, jj, jk, jn)))
              END DO
            END DO
          END DO
          !$ACC END KERNELS
        END SELECT
      END IF
      !$ACC KERNELS
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            pta(ji, jj, jk, jn) = pta(ji, jj, jk, jn) + zsign * (ztfw(ji, jj, jk + 1) - ztfw(ji, jj, jk)) / (e1e2t(ji, jj) * e3t_n(ji, jj, jk))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
      IF ((kpass == 1 .AND. ln_traldf_lap) .OR. (kpass == 2 .AND. ln_traldf_blp)) THEN
        IF (l_ptr) CALL dia_ptr_hst(jn, 'ldf', zftv(:, :, :))
        IF (l_hst) CALL dia_ar5_hst(jn, 'ldf', zftu(:, :, :), zftv(:, :, :))
      END IF
    END DO
  END SUBROUTINE tra_ldf_triad
END MODULE traldf_triad


***
      SUBROUTINE MIX(M0,M,AJ,KS,ZPARS,krol,
* A. Tanikawa adds here 21/10/14
     &     tphys,tmrg,tcon,tkhq,rmrg,emrg)
*
*
*     Author : J. R. Hurley
*     Date :   7th July 1998
*
*       Evolution parameters for mixed star.
*       ------------------------------------
*
* Tanikawa adds this announcement.
*
      use iso_c_binding
*
      implicit none
*
      INTEGER KS(2),I1,I2,K1,K2,KW,ICASE,krol(2)
      INTEGER KTYPE(0:14,0:14)
      COMMON /TYPES/ KTYPE
      REAL*8 M0(2),M(2),AJ(2),ZPARS(20)
      REAL*8 TSCLS(20),LUMS(10),GB(10),TMS1,TMS2,TMS3,TN
      REAL*8 M01,M02,M03,M1,M2,M3,AGE1,AGE2,AGE3,MC3,MCH
      PARAMETER(MCH=1.44D0)
      REAL*8 NETA,BWIND,HEWIND,MXNS,betaacc
      COMMON /VALUE1/ NETA,BWIND,HEWIND,MXNS,betaacc
*
* A. Tanikawa adds here 21/10/14
*
      include 'cppinterface.h'
      real*8 tphys, q
      real*8 tmrg(2), tcon(2), tkhq(2), rmrg(2), emrg(2)
*
*
*
* A. Tanikawa adds here to prevent HGCE 21/02/22
      icase = ktype(krol(1),krol(2))
*
*       Define global indices with body #I1 being most evolved.
      IF(KS(1).GE.KS(2))THEN
          I1 = 1
          I2 = 2
      ELSE
          I1 = 2
          I2 = 1
      END IF
*
*       Specify case index for collision treatment.
      K1 = KS(I1)
      K2 = KS(I2)
* A. Tanikawa comments out here to prevent HGCE 21/02/22
!      ICASE = KTYPE(K1,K2)
*
*     if(icase.gt.100) WRITE(66,*)' MIX ERROR ICASE>100 ',icase,k1,k2
*
*       Determine evolution time scales for first star.
      M01 = M0(I1)
      M1 = M(I1)
      AGE1 = AJ(I1)
      CALL star(K1,M01,M1,TMS1,TN,TSCLS,LUMS,GB,ZPARS)
*
*       Obtain time scales for second star.
      M02 = M0(I2)
      M2 = M(I2)
      AGE2 = AJ(I2)
      CALL star(K2,M02,M2,TMS2,TN,TSCLS,LUMS,GB,ZPARS)
*
*       Check for planetary systems - defined as HeWDs and low-mass WDs!
      IF(K1.EQ.10.AND.M1.LT.0.05)THEN
         ICASE = K2
         IF(K2.LE.1)THEN
            ICASE = 1
            AGE1 = 0.D0
         ENDIF
      ELSEIF(K1.GE.11.AND.M1.LT.0.5.AND.ICASE.EQ.6)THEN
         ICASE = 9
      ENDIF
      IF(K2.EQ.10.AND.M2.LT.0.05)THEN
         ICASE = K1
         IF(K1.LE.1)THEN
            ICASE = 1
            AGE2 = 0.D0
         ENDIF
      ENDIF
*
*       Specify total mass.
      M3 = M1 + M2
      M03 = M01 + M02
      KW = ICASE
      AGE3 = 0.d0
*
*       Restrict merged stars to masses less than 100 Msun.
      if(askInUseOrNot()) then
      else
         IF(M3.GE.100.D0)THEN
            M3 = 99.D0
            M03 = MIN(M03,M3)
         ENDIF
      endif
*
*       Evaluate apparent age and other parameters.
*
      IF(ICASE.EQ.1)THEN
*       Specify new age based on complete mixing.
         IF(K1.EQ.7) KW = 7
         CALL star(KW,M03,M3,TMS3,TN,TSCLS,LUMS,GB,ZPARS)
         !AGE3 = 0.1d0*TMS3*(AGE1*M1/TMS1 + AGE2*M2/TMS2)/M3
         AGE3 = TMS3*(AGE1*M1/TMS1 + AGE2*M2/TMS2)/M3
* A. Tanikawa adds here to prevent HGCE 21/02/22
      ELSEIF(ICASE.EQ.2)THEN
         CALL star(KW,M03,M3,TMS3,TN,TSCLS,LUMS,GB,ZPARS)
         AGE3 = 0.1d0*TMS3*(AGE1*M1/TMS1 + AGE2*M2/TMS2)/M3
*
      ELSEIF(ICASE.EQ.3.OR.ICASE.EQ.6.OR.ICASE.EQ.9)THEN
         MC3 = M1
         CALL gntage(MC3,M3,KW,ZPARS,M03,AGE3)
* A. Tanikawa changes here to prevent HGCE 21/02/22
!      ELSEIF(ICASE.EQ.4)THEN
      ELSEIF(ICASE.EQ.4.or.ICASE.EQ.5)THEN
*
         MC3 = M1
         AGE3 = AGE1/TMS1
         CALL gntage(MC3,M3,KW,ZPARS,M03,AGE3)
      ELSEIF(ICASE.EQ.7)THEN
         CALL star(KW,M03,M3,TMS3,TN,TSCLS,LUMS,GB,ZPARS)
         AGE3 = TMS3*(AGE2*M2/TMS2)/M3
      ELSEIF(ICASE.LE.12)THEN
*       Ensure that a new WD has the initial mass set correctly.
         M03 = M3
         IF(ICASE.LT.12.AND.M3.GE.MCH)THEN
            M3 = 0.D0
            KW = 15
         ENDIF
      ELSEIF(ICASE.EQ.13.OR.ICASE.EQ.14)THEN
*       Set unstable Thorne-Zytkow object with fast mass loss of envelope
*       unless the less evolved star is a WD, NS or BH.
         IF(K2.LT.10)THEN
            M03 = M1
            M3 = M1
         ENDIF
         IF(ICASE.EQ.13.AND.M3.GT.MXNS) KW = 14
      ELSEIF(ICASE.EQ.15)THEN
         M3 = 0.D0
      ELSEIF(ICASE.GT.100)THEN
*       Common envelope case which should only be used after COMENV.
         KW = K1
         AGE3 = AGE1
         M3 = M1
         M03 = M01
      ELSE
*       This should not be reached.
        KW = 1
        M03 = M3
      ENDIF
* A. Tanikawa adds this subroutine 21/10/14
      if(kw.le.1) then
         if(m(1).gt.m(2)) then
            q = m(2)/m(1)
         else
            q = m(1)/m(2)
         endif
         call mixquantity(tphys,kw,m03,age3,m3,q,
     &        tmrg,tcon,tkhq,rmrg,emrg)
      endif
*
*
* Put the result in *1.
*
      KS(1) = KW
      KS(2) = 15
      M(1) = M3
      M(2) = 0.D0
      M0(1) = M03
      AJ(1) = AGE3
*
      RETURN
      END
***

* A. Tanikawa adds this subroutine 21/10/14
      subroutine mixquantity0(tphys,kw,m0,aj,mt,q,tmrg,tcon,rmrg,emrg)
      use iso_c_binding
      implicit none
*
      real*8 TkhSunMyr
      parameter (TkhSunMyr=1.570d1)
      real*8 qc
      parameter (qc=3.0d-1)
      real*8 tphys, q
      integer kw
      real*8 m0,aj,mt,tm,tn,tscls(20),lums(10),gb(10),zpars(20)
      real*8 r,lum,mc,rc,menv,renv,k2,ffb,tsn
      real*8 jspin,arem
      real*8 ragbf
      real*8 rg
      real*8 tmrg(2), tcon(2), rmrg(2), emrg(2)
      real*8 tmrg3, rmrg3, tcon3, emrg3
      real*8 uagb, ubse, umrg
      include 'cppinterface.h'
*
      tmrg3 = -1.
      call star(kw,m0,mt,tm,tn,tscls,lums,gb,zpars)
      call hrdiag(m0,aj,mt,tm,tn,tscls,lums,gb,zpars,
     &     r,lum,kw,mc,rc,menv,renv,k2,ffb,tsn,
     &     jspin,arem,
     &     tphys,tmrg3,0.,0.)
      tmrg3 = tphys
      if(askInUseOrNot()
     &     .and. askInScopeOfApplication(m0)) then
         rg = 10**(getRadiusRedPhase(mt,lum))
      else
         rg = ragbf(mt,lum,zpars(2))
      endif
      ubse   = - mt**2/(2.*r)
      uagb   = - mt**2/(2.*rg)
      emrg3 = uagb - ubse
      if(q .lt. qc) then
         emrg3 = emrg3 * ((qc/q)*uagb-ubse)/(uagb-ubse)
      endif
      umrg = ubse + emrg3
      if(tmrg(1).ge.0.) then
         umrg  = umrg  + (1.-min(1.,(tphys-tmrg(1))/tcon(1)))*emrg(1)
         emrg3 = emrg3 + (1.-min(1.,(tphys-tmrg(1))/tcon(1)))*emrg(1)
      endif
      if(tmrg(2).ge.0.) then
         umrg  = umrg  + (1.-min(1.,(tphys-tmrg(2))/tcon(2)))*emrg(2)
         emrg3 = emrg3 + (1.-min(1.,(tphys-tmrg(2))/tcon(2)))*emrg(2)
      endif
      umrg  = max(ubse,min(umrg,uagb))
      rmrg3 = - mt**2/(2.*umrg)
      tcon3 = max(0.,(1.-(r/rmrg3))*mt**2/(r*lum)*TkhSunMyr)
      tmrg(1) = tmrg3
      tmrg(2) = -1.
      tcon(1) = tcon3
      tcon(2) = -1.
      rmrg(1) = rmrg3
      rmrg(2) = -1.
      emrg(1) = emrg3
      emrg(2) = -1.
*
      return
      end
*

* A. Tanikawa adds this subroutine 21/10/14
      subroutine mixquantity(tphys,kw,m0,aj,mt,q,
     &     tmrg,tcon,tkhq,rmrg,emrg)
      use iso_c_binding
      implicit none
*
      real*8 TkhSunMyr
      parameter (TkhSunMyr=1.570d1)
      real*8 qc1,qc2,fqc2
      parameter (qc1=3.0d-1,fqc2=0.1)
      real*8 tphys, q
      integer kw,kwold
      real*8 m0,aj,mt,tm,tn,tscls(20),lums(10),gb(10),zpars(20)
      real*8 r,lum,mc,rc,menv,renv,k2,ffb,tsn
      real*8 jspin,arem
      real*8 ragbf
      real*8 rg
      real*8 tmrg(2), tcon(2), tkhq(2), rmrg(2), emrg(2)
      real*8 tmrg3, rmrg3, tcon3, emrg3
      real*8 uagb, ubse, umrg
      include 'cppinterface.h'
*
      tmrg3 = -1.
      kwold = kw
      call star(kw,m0,mt,tm,tn,tscls,lums,gb,zpars)
      call hrdiag(m0,aj,mt,tm,tn,tscls,lums,gb,zpars,
     &     r,lum,kw,mc,rc,menv,renv,k2,ffb,tsn,
     &     jspin,arem,
     &     tphys,tmrg3,0.,0.)
      tmrg3 = tphys
      if(askInUseOrNot()
     &     .and. askInScopeOfApplication(m0)) then
         rg = 10**(getRadiusRedPhase(mt,lum))
      else
         rg = ragbf(mt,lum,zpars(2))
      endif
      ubse  = - mt**2/(2.*r)
      uagb  = - mt**2/(2.*rg)
      qc2   = qc1 * uagb / ((fqc2 * (uagb-ubse) + ubse))
      emrg3 = uagb - ubse
      if(q .lt. qc2) then
         emrg3 = emrg3 * ((qc1/qc2)*uagb-ubse)/(uagb-ubse) * q/qc2
      elseif(q .lt. qc1) then
         emrg3 = emrg3 * ((qc1/q)*uagb-ubse)/(uagb-ubse)
      endif
      umrg = ubse + emrg3
      if(tmrg(1).ge.0.
     &     .and. 1.-(tphys-tmrg(1))/(tkhq(1)) .ge. 0) then
         umrg  = umrg  + emrg(1)
         emrg3 = emrg3 + emrg(1)
      endif
      if(tmrg(2).ge.0.
     &     .and. 1.-(tphys-tmrg(2))/(tkhq(2)) .ge. 0) then
         umrg  = umrg  + emrg(2)
         emrg3 = emrg3 + emrg(2)
      endif
      umrg  = min(umrg,uagb)
      if(umrg .lt. ubse .and. kw.eq.kwold) then
         write(0,*) 'Error: umrg < ubse in mixquantity.'
         write(0,*) 'ubse umrg uagb', ubse, umrg, uagb
         stop
      endif
      rmrg3 = - mt**2/(2.*umrg)
      tcon3 = max(0.,(1.-(r/rmrg3))*mt**2/(r*lum)*TkhSunMyr)
      tmrg(1) = tmrg3
      tmrg(2) = -1.
      tcon(1) = tcon3
      tcon(2) = -1.
      tkhq(1) = mt**2/(r*lum)*TkhSunMyr*q
      tkhq(2) = -1.
      rmrg(1) = rmrg3
      rmrg(2) = -1.
      emrg(1) = emrg3
      emrg(2) = -1.
      if(kw.ne.kwold) then
         tmrg(1) = -1.
         tcon(1) = -1.
         tkhq(1) = -1.
         rmrg(1) = -1.
         emrg(1) = -1.
      endif
*
      return
      end
*