      SUBROUTINE ACTFLT(ITEST,T,ETA)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      COMMON/ACFILT/ACPARM(20),IACFLT(20)
C
      COMMON/ACTOUT/SOUT,VOUT,WOUT
C
      COMMON/CONSTS/PI,TWOPI,RAD
C
      COMMON/CSTVAL/TST
C
      COMMON/CFILTW/TSTART,DVWP(3),DVWM(3),TREF1,TREF2
C
      COMMON/CWHEEL/WSP(3),VWUP(3),VWDN(3)
C
      COMMON/DEBUG2/IOUT,JOUT,KLUGE
C
      COMMON/ITCNTL/IPULSE,ISPLSE,KPULSE,IDV1(3)
C
      COMMON/MOMENT/IDV2(4),IWHEEL,IDV3
C
      COMMON/OUTTHR/SMAGB(3),XMB1(3),RWHEEL(3)
C
      COMMON/PWHEEL/XMOMIN(3),DVW(3),VMOM(3),VW(3)
C
      COMMON/RMGNTC/SMAGI(3)
C
      COMMON/RPOOL1/DUM1(11),SA(3,3),DUM2(19),OMEG(3),DUM3(83)
C
      COMMON/SENVTR/DIY(3),DL2
C
      COMMON/SUNVTR/SLB(3)
C
      COMMON/VARBLS/DEP(150),DER(150)
C
C
      DIMENSION ETA(7),UVEC(3),SPOS(3),ACC(3)
      DIMENSION VWDOT(3)
C
C
      EQUIVALENCE (GAIN,ACPARM(1)),(TAU,ACPARM(2)),(UVEC(1),ACPARM(3))
      EQUIVALENCE (SPOS(1),ACPARM(6))
      EQUIVALENCE (WTAU,ACPARM(9))
      EQUIVALENCE (ACTTD,ACPARM(10))
      EQUIVALENCE (IFLT,IACFLT(1)),(ITYPE,IACFLT(2)),(ISEN,IACFLT(3))
      EQUIVALENCE (IIC,IACFLT(4)),(IFLAG,IACFLT(5)),(NDEP,IACFLT(6))
C
C
C     ITYPE 1 ACTUATES PULSED THRUSTING
C     ITYPE 2 ACTUATES MOMENTUM WHEEL CYCLING
C
C
      IF(ITEST.EQ.1) GO TO 4
      IF(IFLT.EQ.0) RETURN
      GO TO 100
    4 CONTINUE
C
      IF(T.EQ.TST) TSTART=TST
      DO 5 I=1,3
      DIY(I)=SLB(I)
    5 CONTINUE
C
      IF(ISPLSE.NE.2.AND.ISEN.NE.1) GO TO 8
      CALL HAG
      SUM=0.0D0
      DO 6 I=1,3
      SMAGB(I)=SA(1,I)*SMAGI(1)+SA(2,I)*SMAGI(2)+SA(3,I)*SMAGI(3)
      SUM=SUM+SMAGB(I)*SMAGB(I)
    6 CONTINUE
      SUM=DSQRT(SUM)
      DO 7 I=1,3
      DIY(I)=SMAGB(I)/SUM
    7 CONTINUE
C
    8 CONTINUE
C
      IF(IFLT.EQ.0) RETURN
      IF(T.GT.TST) GO TO 10
C
C
      VLP=DEP(NDEP)
      VLAST=VLP
      TLP=T
      TLAST=T
      ISW=0
C
C
       IF(ITYPE.EQ.1) GO TO 90
      IF(WTAU.NE.0.0D0) GO TO 1
      WS=OMEG(3)
      WS=DABS(WS)
      IF(WS.EQ.0.0D0) WS=1.0D0
      WTAU=TWOPI/WS
    1 CONTINUE
C
      DO 2 I=1,3
      DVWP(I)=(VWUP(I)-VWDN(I))/WTAU
      DVWM(I)=-DVWP(I)
    2 CONTINUE
      TREF1=-1.0D0
      DO 3 I=1,3
      IF(DVWP(I).EQ.0.0D0) GO TO 3
      TD=WTAU*(VWUP(I)-VW(I))/(VWUP(I)-VWDN(I))
      IF(TD.GT.TREF1) TREF1=TD
    3 CONTINUE
C
C
      GO TO 90
C
   10 CONTINUE
C
      VNOW=DEP(NDEP)
      TNOW=T
      IF(TNOW.LE.TLAST) GO TO 12
      VLP=VLAST
      TLP=TLAST
C
   12 CONTINUE
C
      VLAST=VNOW
      TLAST=TNOW
      IF(ITYPE.EQ.1) GO TO 90
      IF(ISW.EQ.1) GO TO 20
      IF(VLAST.LE.0.0D0) GO TO 90
      IF(VLP.GT.0.0D0) GO TO 90
      TDIF=TLAST-TLP
      TCROSS=TLP-TDIF*VLP/(VLAST-VLP)
      ISW=1
      TREF2=TCROSS+TREF1+ACTTD
      TREF1=TCROSS+ACTTD
      TSTART=TREF1
      ISIGN=1
      DO 14 I=1,3
      VW(I)=WSP(I)
      VWDOT(I)=DVWP(I)
   14 CONTINUE
C
   20 CONTINUE
C
      IF(TLAST.LT.TREF1) GO TO 95
      DO 22 I=1,3
      DVW(I)=VWDOT(I)
   22 CONTINUE
      IF(TLAST.LT.TREF2) GO TO 95
C
C     SWITCH MOMENTUM WHEEL ACC
C
      IF(ISIGN.LT.0) GO TO 30
C
      DO 25 I=1,3
      VWDOT(I)=DVWM(I)
      VW(I)=WSP(I)
   25 CONTINUE
      TSTART=TREF2
      TREF1=TREF2
      TREF2=TREF2+WTAU
      ISIGN=-1
C
      GO TO 20
C
   30 CONTINUE
C
      DO 35 I=1,3
      VWDOT(I)=DVWP(I)
      VW(I)=WSP(I)
   35 CONTINUE
      TSTART=TREF2
      TREF1=TREF2
      TREF2=TREF2+WTAU
      ISIGN=1
C
      GO TO 20
C
   90 CONTINUE
C
      IF(ITYPE.EQ.2) GO TO 95
C
      WS=DABS(VLAST)
      IF(WS.LT.0.1D0) DIY(1)=0.1D0
      DIY(2)=VLAST
C
   95 CONTINUE
C
C
      RETURN
C
C
  100 CONTINUE
C
      IF(ISEN.GT.1) GO TO 110
C
C     SENSOR MEASURES MAGNETIC FIELD
C
      SOUT=UVEC(1)*SMAGB(1)+UVEC(2)*SMAGB(2)+UVEC(3)*SMAGB(3)
      GO TO 150
C
  110 CONTINUE
C
      IF(ISEN.GT.2) GO TO 120
C
C     SENSOR IS AN ACCELEROMETER
C
      O11=OMEG(1)*OMEG(1)
      O22=OMEG(2)*OMEG(2)
      O33=OMEG(3)*OMEG(3)
      O12=OMEG(1)*OMEG(2)
      O13=OMEG(1)*OMEG(3)
      O23=OMEG(2)*OMEG(3)
      ACC(1)=ETA(1)+ETA(5)*SPOS(3)-ETA(6)*SPOS(2)
     1       -(O22+O33)*SPOS(1)+O12*SPOS(2)+O13*SPOS(3)
      ACC(2)=ETA(2)+ETA(6)*SPOS(1)-ETA(4)*SPOS(3)
     1       +O12*SPOS(1)-(O33+O11)*SPOS(2)+O23*SPOS(3)
      ACC(3)=ETA(3)+ETA(4)*SPOS(2)-ETA(5)*SPOS(1)
     1       +O13*SPOS(1)+O23*SPOS(2)-(O11+O22)*SPOS(3)
      SOUT=ACC(1)*UVEC(1)+ACC(2)*UVEC(2)+ACC(3)*UVEC(3)
      GO TO 150
C
  120 CONTINUE
C
      IF(ISEN.GT.3) GO TO 130
C
C     SENSOR IS A BODY RATE SENSOR ?
C
      SOUT=UVEC(1)*OMEG(1)+UVEC(2)*OMEG(2)+UVEC(3)*OMEG(3)
      GO TO 150
C
  130 CONTINUE
C
C     SENSOR IS A SUN SENSOR
C
      SOUT=UVEC(1)*SLB(1)+UVEC(2)*SLB(2)+UVEC(3)*SLB(3)
C
  150 CONTINUE
C
      IF(IIC.NE.0) GO TO 160
C     PUT IN INITIAL CONDITIONS FOR FILTER
C
C
      DEP(NDEP+1)=0.0D0
      DEP(NDEP)=SOUT*GAIN
      VLAST=DEP(NDEP)
      VLP=VLAST
      TLAST=T
      TLP=T
      IIC=1
      IF(ITYPE.EQ.2) GO TO 160
      DL2=DEP(NDEP)
C
  160 CONTINUE
C
      I2=NDEP+1
      DER(NDEP)=(GAIN*SOUT-DEP(NDEP)-DEP(I2))/TAU
      DER(I2)=DER(NDEP)+DEP(NDEP)/TAU
      VOUT=DEP(NDEP)
      WOUT=DEP(I2)
C
C
      RETURN
C
      END


MODULE trdken
  USE oce
  USE dom_oce
  USE phycst
  USE sbc_oce
  USE zdf_oce
  USE ldftra
  USE trd_oce
  USE trdvor
  USE trdglo
  USE trdmxl
  USE in_out_manager
  USE iom
  USE lib_mpp
  USE ldfslp
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: trd_ken
  PUBLIC :: trd_ken_init
  INTEGER :: nkstp
  REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :, :) :: bu, bv
  REAL(KIND = wp), ALLOCATABLE, DIMENSION(:, :, :) :: r1_bt
  CONTAINS
  INTEGER FUNCTION trd_ken_alloc()
    ALLOCATE(bu(jpi, jpj, jpk), bv(jpi, jpj, jpk), r1_bt(jpi, jpj, jpk), STAT = trd_ken_alloc)
    IF (lk_mpp) CALL mpp_sum(trd_ken_alloc)
    IF (trd_ken_alloc /= 0) CALL ctl_warn('trd_ken_alloc: failed to allocate arrays')
  END FUNCTION trd_ken_alloc
  SUBROUTINE trd_ken(putrd, pvtrd, ktrd, kt)
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: putrd, pvtrd
    INTEGER, INTENT(IN   ) :: ktrd
    INTEGER, INTENT(IN   ) :: kt
    INTEGER :: ji, jj, jk
    INTEGER :: ikbu, ikbv
    INTEGER :: ikbum1, ikbvm1
    REAL(KIND = wp), DIMENSION(:, :), ALLOCATABLE :: z2dx, z2dy, zke2d
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zke
    CALL lbc_lnk_multi(putrd, 'U', - 1., pvtrd, 'V', - 1.)
    !$ACC KERNELS
    nkstp = kt
    DO jk = 1, jpkm1
      bu(:, :, jk) = e1e2u(:, :) * e3u_n(:, :, jk)
      bv(:, :, jk) = e1e2v(:, :) * e3v_n(:, :, jk)
      r1_bt(:, :, jk) = r1_e1e2t(:, :) / e3t_n(:, :, jk) * tmask(:, :, jk)
    END DO
    zke(:, :, jpk) = 0._wp
    zke(1, :, :) = 0._wp
    zke(:, 1, :) = 0._wp
    DO jk = 1, jpkm1
      DO jj = 2, jpj
        DO ji = 2, jpi
          zke(ji, jj, jk) = 0.5_wp * rau0 * (un(ji, jj, jk) * putrd(ji, jj, jk) * bu(ji, jj, jk) + un(ji - 1, jj, jk) * putrd(ji - 1, jj, jk) * bu(ji - 1, jj, jk) + vn(ji, jj, jk) * pvtrd(ji, jj, jk) * bv(ji, jj, jk) + vn(ji, jj - 1, jk) * pvtrd(ji, jj - 1, jk) * bv(ji, jj - 1, jk)) * r1_bt(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    SELECT CASE (ktrd)
    CASE (jpdyn_hpg)
      CALL iom_put("ketrd_hpg", zke)
    CASE (jpdyn_spg)
      CALL iom_put("ketrd_spg", zke)
    CASE (jpdyn_pvo)
      CALL iom_put("ketrd_pvo", zke)
    CASE (jpdyn_rvo)
      CALL iom_put("ketrd_rvo", zke)
    CASE (jpdyn_keg)
      CALL iom_put("ketrd_keg", zke)
    CASE (jpdyn_zad)
      CALL iom_put("ketrd_zad", zke)
    CASE (jpdyn_ldf)
      CALL iom_put("ketrd_ldf", zke)
    CASE (jpdyn_zdf)
      CALL iom_put("ketrd_zdf", zke)
      ALLOCATE(z2dx(jpi, jpj), z2dy(jpi, jpj), zke2d(jpi, jpj))
      !$ACC KERNELS
      z2dx(:, :) = un(:, :, 1) * (utau_b(:, :) + utau(:, :)) * e1e2u(:, :) * umask(:, :, 1)
      z2dy(:, :) = vn(:, :, 1) * (vtau_b(:, :) + vtau(:, :)) * e1e2v(:, :) * vmask(:, :, 1)
      zke2d(1, :) = 0._wp
      zke2d(:, 1) = 0._wp
      DO jj = 2, jpj
        DO ji = 2, jpi
          zke2d(ji, jj) = r1_rau0 * 0.5_wp * (z2dx(ji, jj) + z2dx(ji - 1, jj) + z2dy(ji, jj) + z2dy(ji, jj - 1)) * r1_bt(ji, jj, 1)
        END DO
      END DO
      !$ACC END KERNELS
      CALL iom_put("ketrd_tau", zke2d)
      DEALLOCATE(z2dx, z2dy, zke2d)
    CASE (jpdyn_bfr)
      CALL iom_put("ketrd_bfr", zke)
    CASE (jpdyn_atf)
      CALL iom_put("ketrd_atf", zke)
    CASE (jpdyn_ken)
      !$ACC KERNELS
      zke(:, :, :) = 0.5_wp * zke(:, :, :)
      !$ACC END KERNELS
      CALL iom_put("KE", zke)
      CALL ken_p2k(kt, zke)
      CALL iom_put("ketrd_convP2K", zke)
    END SELECT
  END SUBROUTINE trd_ken
  SUBROUTINE ken_p2k(kt, pconv)
    INTEGER, INTENT(IN   ) :: kt
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(  OUT) :: pconv
    INTEGER :: ji, jj, jk
    INTEGER :: iku, ikv
    REAL(KIND = wp) :: zcoef
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zconv
    !$ACC KERNELS
    zcoef = - rau0 * grav * 0.5_wp
    zconv(:, :, 1) = zcoef * (2._wp * rhd(:, :, 1)) * wn(:, :, 1) * e3w_n(:, :, 1)
    DO jk = 2, jpk
      zconv(:, :, jk) = zcoef * (rhd(:, :, jk) + rhd(:, :, jk - 1)) * wn(:, :, jk) * e3w_n(:, :, jk)
    END DO
    DO jk = 1, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          zcoef = 0.5_wp / e3t_n(ji, jj, jk)
          pconv(ji, jj, jk) = zcoef * (zconv(ji, jj, jk) + zconv(ji, jj, jk + 1)) * tmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE ken_p2k
  SUBROUTINE trd_ken_init
    INTEGER :: ji, jj, jk
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'trd_ken_init : 3D Kinetic Energy trends'
      WRITE(numout, FMT = *) '~~~~~~~~~~~~~'
    END IF
    IF (trd_ken_alloc() /= 0) CALL ctl_stop('trd_ken_alloc: failed to allocate arrays')
  END SUBROUTINE trd_ken_init
END MODULE trdken