      subroutine rexsph ( mphase, ipr2, ispec, vixan, xkstep, xkmax,
     1             gamach, rgrd,
     1             nph, lmaxph, potlbl, spinph, iatph, nat, rat, iphat,
     2             ixc, vr0, vi0, ixc0, lreal, rfms2, lfms2, l2lp,
     3             ipol, ispin, le2, angks, ptz, iPl, iGrid,
     4             izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis)

      use json_module
      implicit double precision (a-h, o-z)
      logical :: found
      type(json_file) :: json   !the JSON structure read from the file:
      double precision toss
      integer,dimension(:),allocatable :: intgs
      character*80,dimension(:),allocatable :: strings
      double precision,dimension(:),allocatable :: dbpcs

      include '../HEADERS/const.h'
      include '../HEADERS/dim.h'

cc    geom.dat
      integer  nat, iatph(0:nphx), iphat(natx), ibounc(natx)
      double precision  rat(3,natx)
cc    global.dat
c       configuration average
        integer nabs, iphabs
c       global polarization data
        integer  ipol, ispin, le2
        double precision evec(3), xivec(3), spvec(3), elpty,angks,rclabs
        complex*16 ptz(-1:1, -1:1)
cc    mod2.inp
        integer mphase, ipr2, ixc, ixc0, ispec, lreal, lfms2, l2lp, iPl,
     &       iGrid
        double precision rgrd, gamach, xkstep, xkmax, vixan
        double precision vr0, vi0, spinph(0:nphx)
        real rfms2
        integer lmaxph(0:nphx)
        character*6  potlbl(0:nphx)
        integer izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis

c     Local stuff
c      character*512 slog
c      character*80 head(nheadx)
c      dimension lhead(nheadx)

c     standard formats for string, integers and real numbers
c  10  format(a)
c  20  format (20i4)
c  30  format (6f13.5)

      call json_read_geom(nat, nph, iatph, rat, iphat, ibounc)

      call json_read_global(nabs, iphabs, rclabs, ipol, ispin, le2,
     1                      elpty, angks, evec, xivec, spvec, ptz)

c--json--c     Read  geom.dat file
c--json--      open (file='geom.dat', unit=3, status='old',iostat=ios)
c--json--c       read header from geom.dat
c--json--        nhead = nheadx
c--json--        call rdhead (3, nhead, head, lhead)
c--json--        nat = 0
c--json--        nph = 0
c--json--        do 40 iph = 0, nphx
c--json--  40    iatph(iph) = 0
c--json--  50    continue
c--json--           nat = nat+1
c--json--           if (nat .gt. natx)  then
c--json--              write(slog,55) ' nat, natx ', nat, natx
c--json--              call wlog(slog)
c--json--  55          format(a, 2i10)
c--json--              stop 'Bad input'
c--json--           endif
c--json--           read(3,*,end=60)  idum, (rat(j,nat),j=1,3), iphat(nat), i1b
c--json--           if (iphat(nat).gt.nph) nph = iphat(nat)
c--json--           if ( iatph(iphat(nat)).eq.0) iatph(iphat(nat)) = nat
c--json--        goto 50
c--json--  60    continue
c--json--        nat = nat-1
c--json--      close(3)

cc    global.inp
c--json--      open (file='global.dat', unit=3, status='unknown',iostat=ios)
c--json--c       configuration average data
c--json--        read  (3, 10) slog
c--json--        read  (3, 65) nabs, iphabs, rclabs
c--json--  65    format ( 2i8, f13.5)
c--json--c       global polarization data
c--json--        read  (3,10)   slog
c--json--        read  (3, 70)  ipol, ispin, le2, elpty, angks
c--json--  70    format ( 3i5, 2f12.4)
c--json--        read  (3, 10) slog
c--json--        do 80 i = 1,3
c--json--          read  (3,30) evec(i), xivec(i), spvec(i)
c--json--  80    continue
c--json--        read  (3, 10) slog
c--json--        do 90 i = -1, 1
c--json--          read (3,30) a1, b1, a2, b2, a3, b3
c--json--          ptz(-1,i)= dcmplx(a1,b1)
c--json--          ptz(0,i) = dcmplx(a2,b2)
c--json--          ptz(1,i) = dcmplx(a3,b3)
c--json--  90    continue
c--json--      close(3)

c--json--c     read mod2.inp
c--json--c     Josh - added flag iPl for PLASMON card
c--json--c     Josh - added flag iGrid for user controlled grids.
c--json--      open (file='mod2.inp', unit=3, status='old',iostat=ios)
c--json--        read (3,10)  slog
c--json--        read (3,20)  mphase,ipr2,ixc,ixc0,ispec,lreal,lfms2,nph,l2lp,
c--json--     &       iPl,iGrid
c--json--        read (3,10)  slog
c--json--        read (3,30)  vr0, vi0
c--json--        read (3,10)  slog
c--json--        read (3,20)  (lmaxph(iph),iph=0,nph)
c--json--        read (3,10)  slog
c--json--        read (3,170)  (potlbl(iph),iph=0,nph)
c--json--  170   format (13a6)
c--json--        read (3,10)  slog
c--json--        read (3,30)  rgrd, rfms2, gamach, xkstep, xkmax, vixan
c--json--        read (3,30)  (spinph(iph),iph=0,nph)
c--json--        read (3,20)  izstd, ifxc, ipmbse, itdlda, nonlocal, ibasis
c--json--      close(3)

      call json%load_file('xsph.json')
      if (json_failed()) then   !if there was an error reading the file
         print *, "failed to read xsph.json"
         stop
      else
         call json%get('mphase',   mphase, found)
                   if (.not. found) call bailout('mphase', 'xsph.json')
         call json%get('ipr2',   ipr2, found)
                   if (.not. found) call bailout('ipr2', 'xsph.json')
         call json%get('ixc',   ixc, found)
                   if (.not. found) call bailout('ixc', 'xsph.json')
         call json%get('ixc0',   ixc0, found)
                   if (.not. found) call bailout('ixc0', 'xsph.json')
         call json%get('ispec',   ispec, found)
                   if (.not. found) call bailout('ispec', 'xsph.json')
         call json%get('lreal',   lreal, found)
                   if (.not. found) call bailout('lreal', 'xsph.json')
         call json%get('lfms2',   lfms2, found)
                   if (.not. found) call bailout('lfms2', 'xsph.json')
         call json%get('nph',   nph, found)
                   if (.not. found) call bailout('nph', 'xsph.json')
         call json%get('l2lp',   l2lp, found)
                   if (.not. found) call bailout('l2lp', 'xsph.json')
         call json%get('iPlsmn', iPl, found)
                   if (.not. found) call bailout('iPlsmn', 'xsph.json')
         call json%get('iGrid',   iGrid, found)
                   if (.not. found) call bailout('iGrid', 'xsph.json')

         call json%get('vro',   vr0, found)
                   if (.not. found) call bailout('vr0', 'xsph.json')
         call json%get('vio',   vi0, found)
                   if (.not. found) call bailout('vi0', 'xsph.json')

         call json%get('rgrd',   rgrd, found)
                   if (.not. found) call bailout('rgrd', 'xsph.json')
         call json%get('rfms2',  toss, found)
                   if (.not. found) call bailout('rfms2', 'xsph.json')
         rfms2 = real(toss)
         call json%get('gamach',   gamach, found)
                   if (.not. found) call bailout('gamach', 'xsph.json')
         call json%get('xkstep',   xkstep, found)
                   if (.not. found) call bailout('xkstep', 'xsph.json')
         call json%get('xkmax',   xkmax, found)
                   if (.not. found) call bailout('xkmax', 'xsph.json')
         call json%get('vixan',   vixan, found)
                   if (.not. found) call bailout('vixan', 'xsph.json')

         call json%get('izstd',   izstd, found)
                   if (.not. found) call bailout('izstd')
         call json%get('ifxc',   ifxc, found)
                   if (.not. found) call bailout('ifxc')
         call json%get('ipmbse',   ipmbse, found)
                   if (.not. found) call bailout('ipmbse')
         call json%get('itdlda',   itdlda, found)
                   if (.not. found) call bailout('itdlda')
         call json%get('nonlocal',   nonlocal, found)
                   if (.not. found) call bailout('nonlocal')
         call json%get('ibasis',   ibasis, found)
                   if (.not. found) call bailout('ibasis')

         call json%get('potlbl', strings, found)
                   if (.not. found) call bailout('potlbl', 'xsph.json')
         do 1000 itit = 1, nphx
c            potlbl(itit-1) = strings(itit)
            potlbl(itit-1) = strings(itit)(1:6)
 1000    continue
         call json%get('lmaxph', intgs, found)
                   if (.not. found) call bailout('lmaxph', 'xsph.json')
         do 1010 iph = 0, nphx
            lmaxph(iph) = intgs(iph+1)
 1010    continue
         call json%get('spinph', dbpcs, found)
                   if (.not. found) call bailout('spinph', 'xsph.json')
         do 1020 iph = 0, nphx
            spinph(iph) = dbpcs(iph+1)
 1020    continue

         call json%destroy()
      end if

c     transform to code units (bohrs and hartrees - atomic unuts)
      rfms2 = rfms2 / real(bohr)
      vr0   = vr0 / hart
      vi0   = vi0 / hart
      gamach = gamach / hart
      vixan = vixan / hart
      xkstep = xkstep * bohr
      xkmax  = xkmax  * bohr
      do 210 i = 1,3
      do 210 iat = 1, nat
        rat(i,iat) = rat(i,iat) / bohr
 210  continue

      return
      end


c CKDFUF does the initialization (set the variables, call ckd1_init(), etc.)
c and calculates the molecular absorption cross sections ck(ib,i,ig)
c changed error message: increase nvx

      subroutine ckdfuf (co2, ch4, n2o, f11, f12, f22,
     $     rhoair, rhoh2o, rhoo3,
     $     pres, temp, davg, z, nlev, h2o_cont, kg, delg, ck)

      IMPLICIT NONE

      INCLUDE 'fl_radparams.inc'
      INCLUDE 'fl_special.inc'

c Function parameters
      REAL co2, ch4, n2o, f11, f12, f22
      REAL rhoair(nv1x), rhoh2o(nv1x), rhoo3(nv1x)
      REAL pres(nv1x), temp(nv1x), davg(nv1x), z(nv1x)
      LOGICAL h2o_cont
      INTEGER kg(mbx)
      REAL delg(mbx, mg)
      REAL ck(mbx,nvx,mg)
      INTEGER nlev

c Internal variables
      INTEGER I, IB, IG

c Common blocks

c Atmospheric parameters
      REAL    pp, pt, pa, ph, po
      common /atmos/ pp(nv1x), pt(nv1x), pa(nv1x), ph(nv1x), po(nv1x)

c Line absorption optical thickness
      REAL    tg
      common /gas/ tg(nvx)

c Continuum absorption optical thickness
      REAL    tgm
      common /con/ tgm(nvx)

c H20 Continuum absorbtion now for entire LW (5-2200cm-1)
      INTEGER iwtas
      common /cont_tas/ iwtas

      logical lchou,lband6a,lpar,lray
      common /chou/ lchou,lband6a,lpar,lray

c select solar spectrum
      integer isolar_spectrum
      common /select_solar_spectra/ isolar_spectrum

c dz, layer thickness; computation is a little bit different from
c the Fu and Liou code:
c  here,        dz = z(i) - z(i+1)
c  Fu and Liou, dz calculated from pressure difference
      REAL dz
      common /thick/ dz(nvx)

c mixing ratios of the well-mixed gases, CO2, CH4, and N2O
      REAL umco2, umch4, umn2o
      common /umcon/ umco2, umch4, umn2o

c CFCs are only considered if idkfr is set to 1
c (and this is a very expensive option, see
c  option 'if (idkfr .eq. 1) then' )
      REAL cfc_conc(3)
      common /cfcs/ cfc_conc

c band weights
      real hk
      real hk1,  fk1o3,  sol_spect, fk1h2o
      real hk2,  c2h2o
      real hk3,  c3h2o
      real hk4,  c4h2o
      real hk5,  c5h2o
      real hk6,  c6h2o
      real hk7,  c7h2o
      real hk8,  c8h2o
      real hk9,  c9h2o
      real hk10, c10h2o, c10ch4, c10n2o
      real hk11, c11h2o, c11ch4, c11n2o
      real hk12, c12o3,  c12h2o
      real hk13, c13h2o
      real hk14, c14hca, c14hcb
      real hk15, c15hca, c15hcb
      real hk16, c16h2o
      real hk17, c17h2o
      real hk18, c18h2o

      common /band1/  hk1(10),fk1o3(10),sol_spect(0:7),fk1h2o(10)
      common /band2/  hk2(8),c2h2o(3,11,8)
      common /band3/  hk3(12),c3h2o(3,11,12)
      common /band4/  hk4(7),c4h2o(3,11,7)
      common /band5/  hk5(12),c5h2o(3,11,12)
      common /band6/  hk6(5),c6h2o(3,11,5)
      common /band7/  hk7(2),c7h2o(3,19,2)
      common /band8/  hk8(3),c8h2o(3,19,3)
      common /band9/  hk9(4),c9h2o(3,19,4)
      common /band10/ hk10(4),c10h2o(3,19,4),c10ch4(3,19),c10n2o(3,19)
      common /band11/ hk11(3),c11h2o(3,19,3),c11ch4(3,19),c11n2o(3,19)
      common /band12/ hk12(5),c12o3(3,19,5),c12h2o(3,19)
      common /band13/ hk13(2),c13h2o(3,19,2)
      common /band14/ hk14(10),c14hca(3,19,10),c14hcb(3,19,10)
      common /band15/ hk15(12),c15hca(3,19,12),c15hcb(3,19,12)
      common /band16/ hk16(7),c16h2o(3,19,7)
      common /band17/ hk17(7),c17h2o(3,19,7)
      common /band18/ hk18(8),c18h2o(3,19,8)

c Window K's option
c If idkfr is changed, the number of subbands in bands 11, 12, and 13
c is changed (see below); this implies changes at other places in
c libRadtran, e.g. the band weights data/correlated_k/fu/quad.dat
c and the photon fraction files, data/correlated_k/fu/x_solar.dat, etc.
      INTEGER idkfr
      common /dkfrwn/ idkfr
      data idkfr /0/

c H20 Continuum absorbtion now for entire LW (5-2200cm-1)
      data iwtas /3/

c DO NOT CHANGE lchou and lpar because these options require
c action within the solver, too (see rad_0100.f)
      data lchou   /.FALSE./
      data lband6a /.FALSE./

c lpar; PAR water absorption in band 1
      data lpar    /.TRUE./

c lray; if TRUE, the Rayleigh optical depth changes with subband
c which is neccessary because with changing ozone absorption in band 1
c the effective wavelength for Rayleigh changes.
      data lray    /.TRUE./

c select solar spectrum
c be sure that this option equals the data stored in
c data/solar_flux/fu because the flux is read from there!
c For consistency with the Fu and Liou code, the extraterrestrial
c irradiance in data/solar_flux/fu has been scaled to a solar
c constant of 1368 W/m2;
      data isolar_spectrum /1/

      kg(1)  = 10
      kg(2)  = 8
      kg(3)  = 12
      kg(4)  = 7
      kg(5)  = 12
      kg(6)  = 5
      kg(7)  = 2
      kg(8)  = 3
      kg(9)  = 4
      kg(10) = 4
      kg(11) = 3
      kg(12) = 5
      kg(13) = 2
      kg(14) = 10
      kg(15) = 12
      kg(16) = 7
      kg(17) = 7
      kg(18) = 8

c  Depending on Window K's option, the number of subbands needs changes...

      if (idkfr .eq. 0) then
         kg(11) = 3
         kg(12) = 5
         kg(13) = 2
      endif

      if (idkfr .eq. 1) then
         kg(11) = 80
         kg(12) = 40
         kg(13) = 10
      endif

      if (idkfr .eq. 2) then
         kg(11) = 5
         kg(12) = 5
         kg(13) = 2
      endif

c initialize boundaries
      nv    = nlev-1
      nv1   = nv+1

      ndfs  = nv
      mdfs  = nv1
      ndfs4 = 4*ndfs
      ndfs2 = 2*ndfs
      mb    = 18
      mbs   = 6
      mbir  = 12
      nc    = 8

      if(nlev.GT.nv1x) then
        write (*,*) 'error: increase nvx to at least', nlev-1
        write (*,*) '       in fl_radparams.inc and fl_radparams.cinc'
        write (*,*) '       and recompile the package (ckdfuf.f)'
        STOP
      end if

c copy atmospheric data to common blocks
      DO I = 1, nv1
        PP(I) = PRES(I)
        PT(I) = TEMP(I)
        PA(I) = DAVG(I)
        PH(I) = RHOH2O(I)/RHOAIR(I)
        PO(I) = RHOO3(I)/RHOAIR(I)
      ENDDO

      UMCO2 = CO2
      UMCH4 = CH4
      UMN2O = N2O

      cfc_conc(1) = F11
      cfc_conc(2) = F12
      cfc_conc(3) = F22

c initialize layer widths (replacement for thicks())
      DO I = 1, nv
         dz(i) = z(i) - z(i+1)
      ENDDO

c initialize Rayleigh cross sections
c DO NOT REMOVE THIS! It is required in later calls to rayle()
      call rayle2

c initialization; very important; sets e.g. the band weights
      call ckd1_init (isolar_spectrum, lray)

c Loop over bands
      DO ib = 1, mb

c Get the water vapor continuum for band ib
         if (h2o_cont) then
            call gascon_ckd_parm(ib, h2o_cont)
         endif

c Loop over the g's for this band
         DO IG = 1, kg(ib)
c Get the layer optical depths and compute the absorption coefficients
            CALL GASES (ib, IG, HK)
            DO I = 1, nv

               if (h2o_cont) then
                  ck(ib,i,ig) = (tg(I) + tgm(I)) / dz(I)
               else
                  ck(ib,i,ig) = tg(I) / dz(I)
               endif

               IF (ck(ib,i,ig)  .LT. 0.0) THEN
                  WRITE (0,'(1X,A,A,E10.3)') 'Something is wrong,',
     $                 ' negative absorption: ',ck(ib,i,ig)
                  WRITE (0,'(1X,A,I2,A,I3,A,I2)')
     $                 'Band: ',ib, '   Level:',I, '   k:',IG
                  STOP
               ENDIF
            ENDDO
         ENDDO
      ENDDO

c Copy band weights to final destination
      DO IG = 1, kg(1)
         delg(1,ig) = hk1(ig)
      ENDDO

      DO IG = 1, kg(2)
         delg(2,ig) = hk2(ig)
      ENDDO

      DO IG = 1, kg(3)
         delg(3,ig) = hk3(ig)
      ENDDO

      DO IG = 1, kg(4)
         delg(4,ig) = hk4(ig)
      ENDDO

      DO IG = 1, kg(5)
         delg(5,ig) = hk5(ig)
      ENDDO

      DO IG = 1, kg(6)
         delg(6,ig) = hk6(ig)
      ENDDO

      DO IG = 1, kg(7)
         delg(7,ig) = hk7(ig)
      ENDDO

      DO IG = 1, kg(8)
         delg(8,ig) = hk8(ig)
      ENDDO

      DO IG = 1, kg(9)
         delg(9,ig) = hk9(ig)
      ENDDO

      DO IG = 1, kg(10)
         delg(10,ig) = hk10(ig)
      ENDDO

      DO IG = 1, kg(11)
         delg(11,ig) = hk11(ig)
      ENDDO

      DO IG = 1, kg(12)
         delg(12,ig) = hk12(ig)
      ENDDO

      DO IG = 1, kg(13)
         delg(13,ig) = hk13(ig)
      ENDDO

      DO IG = 1, kg(14)
         delg(14,ig) = hk14(ig)
      ENDDO

      DO IG = 1, kg(15)
         delg(15,ig) = hk15(ig)
      ENDDO

      DO IG = 1, kg(16)
         delg(16,ig) = hk16(ig)
      ENDDO

      DO IG = 1, kg(17)
         delg(17,ig) = hk17(ig)
      ENDDO

      DO IG = 1, kg(18)
         delg(18,ig) = hk18(ig)
      ENDDO

      END


PROGRAM array_test
  IMPLICIT NONE
  !Array runs from 1->10
  !Different to most other languages
  !that run 0->9
  INTEGER, DIMENSION(10) :: array
  INTEGER :: i

  !SIZE is an intrinsic function that
  !tells me how large my array is
  DO i = 1, SIZE(array)
    array(i) = i
  END DO

  !Can print whole arrays although large
  !arrays are hard to read
  PRINT *, array

END PROGRAM array_test


  subroutine equilibration ( preeqObj, calcVars, exciton, results )

! ======================================================================
!
!    Calculates pre-equlibrium and equlibrium particle emission.
!    Various parts removed to separate subroutines to streamline
!    the structure.  10/20/03
!
!    Called by: simulatePreequilibrium
!
!    Calls: AUXL FAM MOLNIX PEQEMT PREQAUX STSTCS
!
!    CEM95 written by S. G. Mashnik
!    Edited by A. J. Sierk,  LANL  T-2  February, 1996.
!    Edited by A. J. Sierk,  LANL  T-2  November, 1997.
!    Modified by AJS, February-March, 1999.
!    Modified by SGM to include reduced masses, 1999
!    Modified by SGM at 06/16/2000
!    Last modification by SGM of 04/27/01, to get the module for CEM2k
!    "Last" change: 13-AUG-2003 by NVMokhov
!    Modified by A. J. Sierk, LANL T-16, October, 2003.
!    Modified by K. K. Gudima, December, 2004.
!    Edited by AJS, January, 2005.
!    Edited by SGM 07/09/06 to account for the KKG 06/23/06 changes
!      to use Fermi break-up model in Preco and Evap when A < 13.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!    Modified by LMK, 2014-2015, for expanison of preeq to heavy ions
!
! ======================================================================

    use, intrinsic :: iso_fortran_env, only: int32, real64
    use preequilibriumParams, only : zro, one, two, thr, thousand, ato3rd, emnucb, &
         & emnuct

    implicit none
    class(Preequilibrium),           intent(inout) :: preeqObj
    type(preequilibriumCalculation), intent(inout) :: calcVars
    type(preeqExcitonData),          intent(inout) :: exciton
    type(preequilibriumResults),     intent(inout) :: results

    integer(int32) :: ipflg, k, lm, nsp
    real(real64)   :: am, pevap, ppre, rnp, rr, temp
    logical preqgo

! ======================================================================

    ! Nucleus has low E* ( < 3 MeV) such that no preequilibrium emission will occur
    if (results%residual%thermEnergy < thr) then
       ! Keep track of nuclei returned with less than 3 MeV of E*:
       ! Residual is stable
       results%residual%state = stableState

       ! Check for photon emission:
       if ( preeqObj%usePhotonEmission ) then
          call preeqObj%photonEmission( results%progenyBnk( results%numProgeny ), &
               & results%residual)
       end if

       return
    endif

    ! ---------------------------------
    !   Beginning of main decay loop:
    ! ---------------------------------
    do k = 1, results%maxProgeny

       ! Undergo Fermi Break-up if E* > E_binding (i.e. small nuclei)
       if ( preeqObj%fbuObj%recommendFermiBreakUp(results%residual%numBaryons) ) then
          call  preeqObj%fermiPreeqInterface (results%residual, results )
          results%residual%state = fermiBreakupState
          return
       endif

       ! Obtain energy information for residual
       ! (mass excess)
       calcVars%dl = &
            & preeqObj%molEnergy%defineEnergy &
            & (calcVars%iz, calcVars%in, 2)
       ! (Pairing gap energies)
       pevap = preeqObj%molEnergy%defineEnergy &
            & (calcVars%iz, calcVars%in, 3)
       ! (Thermal energy of nucleus at rotating ground state)
       results%residual%thermEnergy = results%residual%kinEnergy - pevap - results%residual%rotEnergy

! Determine if excited nucleus has low E* (no preequilibrium/evaporation emissions will occur below this threshold)
       if (results%residual%thermEnergy <= 0.1d0) then
          ! Residual nucleus has reached a stable state
          ! NOTE: No compound nucleus remains at this point; it has reached a ground state (stable)
          results%residual%state = stableState

          ! Check for photon emission:
          if ( preeqObj%usePhotonEmission ) then
             call preeqObj%photonEmission( results%progenyBnk( results%numProgeny ), &
                  & results%residual)
          end if

          return
       endif

!   Set up auxiliary quantities for finding prequilibrium
!   emission widths:
       am = preeqObj%fam (results%residual%numBaryons, results%residual%numProtons, &
            & results%residual%thermEnergy, calcVars, 0)
       calcVars%ac = 0.595d0*am
       call preeqObj%preqaux (calcVars, rr, results)

       !  nsp is the number of excitons at which a compound nucleus is
       !  assumed to be formed.
       nsp = int(   sqrt(  abs( 1.19d0 * am * results%residual%numBaryons * &
            & results%residual%kinEnergy + 0.5d0 )  )   )
       preqgo = (preeqObj%options%excludePreeq == 0) .and. (rr > zro)
       lm = 0

10     continue
!  Restore old logic of sharp transition when n > nsp AJS 07/08/05.
       temp = dble(nsp)
       if (temp < div0Lim .and. temp > -div0Lim) then
          temp = div0Lim
          write(preeqObj%io%message,2000) "172"
          call preeqObj%io%print(4, 3, preeqObj%io%message)
       end if
       rnp = dble(exciton%numTotal)/temp

       ! Probability of undergoing pre-equilibrium emission (Eqn. 38 in CEM Manual)
       ! NOTE: The equation used is NOT the same as in the Manual! Either...
       !       (a) the manual needs corrected, or...
       !       (b) the parameters used ought to be refit.
       ppre = one - exp(-0.5d0*((rnp - one)/preeqObj%options%emissionWidth)**2)   ! Gaussian Probability Density Equation
!       ppre = one - exp( -(rnp - one) / (2 * preeqObj%options%emissionWidth**2) )   ! Eqn. 38 of LA-UR-12-01364 (CEM Manual [2012])

       if (exciton%numTotal < nsp .and. preeqObj%rng() < ppre .and. preqgo) then

!  **************** Pre-equilibrium emission *************************
          ipflg = 0
          calcVars%exn = dble(exciton%numTotal)

          ! Undergo preequilibrium emission
          call preeqObj%peqemt (calcVars, exciton, lm, ipflg, results)

          !  ipflg = 1 if number of excitons has changed;
          if (ipflg == 1) go to 10
          !  Otherwise, prequilibrium particle of type lm was emitted (progeny stored into bank)

       else
!  ****************** equilibrium emission ***************************

!   Calculate statistics on average E*, Z, A, L when nucleus enters
!   statistical decay phase.
          results%residual%state = compoundState
          return
       endif
    end do

    ! Preequilibrium particle bank is completely filled during equilibration
    write(preeqObj%io%message,1000) k
    call preeqObj%io%print(1, 3, preeqObj%io%message)
    write(preeqObj%io%message,1100)
    call preeqObj%io%print(1, 3, preeqObj%io%message)
    results%simState = 1

    return
! ======================================================================
1000 format("Preequilibrium progeny bank is full (", i3, " progeny created).", &
          & "Cannot simulate further equilibration of excited residual nucleus.")
1100 format("   Results may be suspect.")
2000 format("Divide by zero error prevented in 'equlibration.90', line ", A)
! ======================================================================
  end subroutine equilibration


*deck sf3eq1
      subroutine sf3eq1( a,        cx,       eta,       g4,
     &         h4,       icb,      icc,      ipt,       is,
     &         isf,      ijgt,     ijx,      ijy,       ijz,
     &         klgt,     klx,      kly,      klz,       lmnp1,
     &         lmnv,     mcons,    nc,       ncon,      nfct,
     &         ngw,      nrcr,     nt,       ntl,       ntu,
     &         x,        y,        z,        zet )
      implicit real*8 (a-h,o-z)
      logical eij, eij1, ekl, esfc, esfcij, esfckl
      common /parmr/ cutoff, tol
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      common /ntgr/itl,itu,jtl,jtu,ktl,ktu,ltl,ltu,jcu,kcu,lcu,inx,
     1  jnx,knx,lnx,nwt,nwt1(3),ijsf(3),klsf(3),icxs(2,3),kcxs(2,3),
     2  npri(2,3),nprk(2,3),iesfb,kesfb,ircru,jrcru,krcru,lrcru
      common /cxindx/ ntij,ntik,ntil,ntkl,ntjl,ntjk,ntij1,ntjk1,ntkl1,
     1  ijcxst(2),ikcxst(2),ilcxst(2),klcxst(2),jlcxst(2),jkcxst(2)
      common /dim21/ ipq(256)
      common /ikpr/ npriri(2,3,8), nprirk(2,3,8)
      common /sf3ao/ ibl
      dimension a(*),cx(*),eta(mrcru,mconu,*),g4(*),h4(*),icb(4,24,*),
     1  ipt(*),ijgt(*),ijx(*),ijy(*),ijz(*),klgt(*),klx(*),kly(*),
     2  klz(*),lmnp1(*),lmnv(3,*),mcons(*),nc(*),ncon(*),nfct(*),ngw(*),
     3  nrcr(*),nt(*),ntl(*),ntu(*),x(mcu,*),y(mcu,*),z(mcu,*),
     4  zet(mconu,*)
      dimension esfc(3),esfcij(3),esfckl(3),icxbg(3,3),jbl(6),kcxbg(3,3)
c
      ic=icb(1,1,icc)
      jc=icb(2,1,icc)
      kc=icb(3,1,icc)
      lc=icb(4,1,icc)
      icxbg(1,1)=ijcxst(1)+ipq((ic-1)*nt(isf)+1)*npri(1,1)+(jc-1)*ntij1
      icxbg(1,2)=icxbg(1,1)+(kc-jc)*ntij1
      icxbg(1,3)=icxbg(1,2)+(lc-kc)*ntij1
      kcxbg(1,1)=ijcxst(1)+ipq((kc-1)*nt(isf)+1)*npri(1,1)+(lc-1)*ntij1
      kcxbg(1,2)=ijcxst(1)+ipq((jc-1)*nt(isf)+1)*npri(1,1)+(lc-1)*ntij1
      kcxbg(1,3)=kcxbg(1,2)+(kc-lc)*ntij1
      icxbg(2,1)=ijcxst(2)+((ic-1)*nc(is)+(jc-1))*ntij
      icxbg(3,1)=icxbg(2,1)-(ic-jc)*((nc(is)-1)*ntij)
      icxbg(2,2)=icxbg(2,1)+(kc-jc)*ntij
      icxbg(3,2)=icxbg(2,2)-(ic-kc)*((nc(is)-1)*ntij)
      icxbg(2,3)=icxbg(2,2)+(lc-kc)*ntij
      icxbg(3,3)=icxbg(2,3)-(ic-lc)*((nc(is)-1)*ntij)
      kcxbg(2,1)=icxbg(2,3)+(kc-ic)*(nc(is)*ntij)
      kcxbg(3,1)=kcxbg(2,1)-(kc-lc)*((nc(is)-1)*ntij)
      kcxbg(2,2)=kcxbg(2,1)+(jc-kc)*(nc(is)*ntij)
      kcxbg(3,2)=kcxbg(2,2)-(jc-lc)*((nc(is)-1)*ntij)
      kcxbg(2,3)=kcxbg(2,2)+(kc-lc)*ntij
      kcxbg(3,3)=kcxbg(2,3)-(jc-kc)*((nc(is)-1)*ntij)
      esfcij(1)=ic.eq.jc
      esfckl(3)=jc.eq.kc
      esfckl(1)=kc.eq.lc
      esfcij(2)=ic.eq.kc
      esfckl(2)=jc.eq.lc
      esfcij(3)=ic.eq.lc
      esfc(1)=esfcij(2).and.esfckl(2)
      esfc(2)=esfcij(1).and.esfckl(1)
      esfc(3)=esfc(2)
      call izero(6,jbl,1)
      do 10 ist=1,nst
        jbl(1)=jbl(1)+ipq(npriri(1,1,ist)+1)
        jbl(3)=jbl(3)+ipq(npriri(2,1,ist)+1)
        jbl(4)=jbl(4)+npriri(1,1,ist)**2
        jbl(5)=jbl(5)+npriri(2,1,ist)*npriri(1,1,ist)
        jbl(6)=jbl(6)+npriri(2,1,ist)**2
   10 continue
      if(esfcij(1).or.esfckl(1)) then
        nwt1(1) = 1
        if(esfckl(3)) then
          iscmu = 1
          go to 30
        else
          iscmu = 2
          go to 28
        endif
      endif
      if(esfckl(3)) then
        iscml = 2
        iscmu = 3
        nwt1(2) = 1
        go to 32
      endif
      if(ngw(icc).eq.1) go to 26
      isw2 = 2
      isw3 = 3
      do 18 igw=2,ngw(icc)
        icb1 = icb(inx,igw,icc)
        icb2 = icb(knx,igw,icc)
        itst1 = max(icb1, icb2)
        itst2 = min(icb1, icb2)
        if((itst1.eq.ic.and.itst2.eq.jc).or.
     &     (itst1.eq.kc.and.itst2.eq.lc)) isw2 = 1
        icb2 = icb(lnx,igw,icc)
        itst1 = max(icb1, icb2)
        itst2 = min(icb1, icb2)
        if((itst1.eq.ic.and.itst2.eq.kc).or.
     &     (itst1.eq.jc.and.itst2.eq.lc)) isw3 = min(isw3,2)
        if((itst1.eq.ic.and.itst2.eq.jc).or.
     &     (itst1.eq.kc.and.itst2.eq.lc)) isw3 = 1
   18 continue
      if(isw3.eq.1) then
        if(isw2.eq.1) then
          iscmu = 1
          nwt1(1) = 3
          go to 30
        else
          iscmu = 2
          nwt1(1) = 2
          go to 28
        endif
      elseif(isw3.eq.2) then
        iscmu = 2
        nwt1(1) = 1
        nwt1(2) = 2
        go to 30
      elseif(isw2.eq.1) then
        iscml = 2
        iscmu = 3
        nwt1(2) = 2
        go to 32
      endif
   26 iscmu = 3
      nwt1(1) = 1
   28 nwt1(2) = 1
   30 iscml = 1
   32 ngt=nt(isf)*(nt(isf)*(nt(isf)*nt(isf)))
      do 98 iscm=iscml,iscmu
      fnfct=nwt1(iscm)*nfct(icc)
      if(iscm-2) 34, 35, 36
   34 call jandk(a,eta,g4,ipt,is,isf,ic,is,isf,jc,is,isf,kc,is,isf,lc,
     &  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     &  nrcr,nt,ntl,ntu,x,y,z,zet)
      go to 38
   35 call jandk(a,eta,g4,ipt,is,isf,ic,is,isf,kc,is,isf,jc,is,isf,lc,
     &  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     &  nrcr,nt,ntl,ntu,x,y,z,zet)
      go to 38
   36 call jandk(a,eta,g4,ipt,is,isf,ic,is,isf,lc,is,isf,jc,is,isf,kc,
     &  ijgt,ijx,ijy,ijz,klgt,klx,kly,klz,lmnp1,lmnv,mcons,ncon,
     &  nrcr,nt,ntl,ntu,x,y,z,zet)
   38 ndx=1
      do 96 ircr=1,ircru
      if(esfc(iscm)) krcru=ircr
      if(esfcij(iscm)) jrcru=ircr
      do 94 jrcr=1,jrcru
      if(ircr-jrcr) 50, 52, 54
   50 ijrcr=ipq(jrcr)+ircr
      ije=jrcr-1
      iesfb1=2
      icxbg1=icxbg(3,iscm)
      ngti1=(nt(isf)*nt(isf))
      ngtj1=(nt(isf)*(nt(isf)*nt(isf)))
      go to 58
   52 ijrcr=ipq(ircr+1)
      ije=ircr
      iesfb1=1
      go to 56
   54 ijrcr=ipq(ircr)+jrcr
      ije=ircr-1
      iesfb1=2
   56 icxbg1=icxbg(iesfb1,iscm)
      ngti1=(nt(isf)*(nt(isf)*nt(isf)))
      ngtj1=(nt(isf)*nt(isf))
   58 ijn=ijrcr-ije
      eij1=esfcij(iscm).and.ircr.eq.jrcr
      do 92 krcr=1,krcru
      if(esfc(iscm).and.ircr.eq.krcr) then
        lrcru = jrcr
      elseif(esfckl(iscm)) then
        lrcru = krcr
      elseif(esfc(iscm)) then
        lrcru = ircru
      endif
      do 90 lrcr=1,lrcru
      if(krcr-lrcr) 60, 62, 64
   60 klrcr=ipq(lrcr)+krcr
      kle=lrcr-1
      kesfb=2
      kcxbg1=kcxbg(3,iscm)
      ngtk1=1
      ngtl1=nt(isf)
      go to 68
   62 klrcr=ipq(krcr+1)
      kle=krcr
      kesfb=1
      go to 66
   64 klrcr=ipq(krcr)+lrcr
      kle=krcr-1
      kesfb=2
   66 kcxbg1=kcxbg(kesfb,iscm)
      ngtk1=nt(isf)
      ngtl1=1
   68 kln=klrcr-kle
      ekl=esfckl(iscm).and.krcr.eq.lrcr
      if(ijrcr-klrcr) 70, 72, 74
   70 if(kesfb.eq.1) then
        iblb=(kle-1)*jbl(1)+kln*jbl(3)+(ipq(kle-1)+ije)*jbl(4)+(kln*
     1    (kle-1)+ijn)*jbl(5)+ipq(kln)*jbl(6)-jbl(iesfb1+3)
      else
        iblb=kle*jbl(1)+(kln-1)*jbl(3)+ipq(kle)*jbl(4)+((kln-1)*kle+
     1    ije)*jbl(5)+(ipq(kln)-kln+1+ijn)*jbl(6)-jbl(iesfb1+4)
      endif
      iesfb=kesfb
      kesfb=iesfb1
      icxs(iesfb,iscm)=kcxbg1
      kcxbg1=icxbg1
      eij=ekl
      ekl=eij1
      ngti=ngtk1
      ngtj=ngtl1
      ngtk=ngti1
      ngtl=ngtj1
      go to 78
   72 iblb=ije*jbl(1)+ijn*jbl(3)+ipq(ije)*jbl(4)+ijn*ije*jbl(5)+
     1  (ipq(ijn+1)-ijn)*jbl(6)-jbl(iesfb1+kesfb-1)
      go to 76
   74 if(iesfb1.eq.1) then
        iblb=(ije-1)*jbl(1)+ijn*jbl(3)+(ipq(ije-1)+kle)*jbl(4)+(ijn*
     1    (ije-1)+kln)*jbl(5)+ipq(ijn)*jbl(6)-jbl(kesfb+3)
      else
        iblb=ije*jbl(1)+(ijn-1)*jbl(3)+ipq(ije)*jbl(4)+((ijn-1)*ije+
     1    kle)*jbl(5)+(ipq(ijn)-ijn+1+kln)*jbl(6)-jbl(kesfb+4)
      endif
   76 iesfb=iesfb1
      icxs(iesfb,iscm)=icxbg1
      eij=eij1
      ngti=ngti1
      ngtj=ngtj1
      ngtk=ngtk1
      ngtl=ngtl1
   78 ndxi=ndx
      do 88 it=itl,itu
        if(((esfc(iscm).and.ircr.eq.krcr).and.jrcr.eq.lrcr)) ktu = it
        ndxj=ndxi
        if(eij) jtu = it
        do 86 jt=itl,jtu
          ndxk=ndxj
          kcxs(kesfb,iscm)=kcxbg1
          do 84 kt=itl,ktu
            ndxl=ndxk
            if(esfc(iscm).and.ircr.eq.krcr.and.jrcr.eq.lrcr.and.
     &         it.eq.kt) then
              ltu = jt
            elseif(ekl) then
              ltu = kt
            elseif(esfc(iscm).and.ircr.eq.krcr.and.jrcr.eq.lrcr) then
              ltu = itu
            endif
            do 82 lt=itl,ltu
              val=g4(ndxl)
              if(abs(val).le.cutoff) go to 80
              val=fnfct*val
              ibl=iblb
              if(ijrcr.eq.klrcr) then
                call aoso2e( h4, cx, iscm, val )
              else
                call aoso2( h4, cx, iscm, val )
              endif
   80         ndxl=ndxl+ngtl
              kcxs(kesfb,iscm)=kcxs(kesfb,iscm)+npri(kesfb,1)
   82       continue
            ndxk=ndxk+ngtk
   84     continue
          ndxj=ndxj+ngtj
          icxs(iesfb,iscm)=icxs(iesfb,iscm)+npri(iesfb,1)
   86   continue
        ndxi=ndxi+ngti
   88 continue
      ndx=ndx+ngt
   90 continue
   92 continue
   94 continue
   96 continue
   98 continue
      return
      end


MODULE zdfosm
  USE oce
  USE dom_oce
  USE zdf_oce
  USE sbc_oce
  USE sbcwave
  USE phycst
  USE eosbn2
  USE traqsr
  USE zdfddm
  USE iom
  USE lib_mpp
  USE trd_oce
  USE trdtra
  USE in_out_manager
  USE lbclnk
  USE prtctl
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: zdf_osm
  PUBLIC :: zdf_osm_init
  PUBLIC :: osm_rst
  PUBLIC :: tra_osm
  PUBLIC :: trc_osm
  PUBLIC :: dyn_osm
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ghamu
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ghamv
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ghamt
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: ghams
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: etmean
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: hbl
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: hbli
  REAL(KIND = wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:, :) :: dstokes
  LOGICAL :: ln_use_osm_la
  REAL(KIND = wp) :: rn_osm_la
  REAL(KIND = wp) :: rn_osm_dstokes
  REAL(KIND = wp) :: rn_osm_hbl0 = 10._wp
  INTEGER :: nn_ave
  INTEGER :: nn_osm_wave = 0
  LOGICAL :: ln_dia_osm
  LOGICAL :: ln_kpprimix = .TRUE.
  REAL(KIND = wp) :: rn_riinfty = 0.7
  REAL(KIND = wp) :: rn_difri = 0.005
  LOGICAL :: ln_convmix = .TRUE.
  REAL(KIND = wp) :: rn_difconv = 1._wp
  REAL(KIND = wp) :: epsln = 1.0E-20_wp
  REAL(KIND = wp) :: pthird = 1._wp / 3._wp
  REAL(KIND = wp) :: p2third = 2._wp / 3._wp
  INTEGER :: idebug = 236
  INTEGER :: jdebug = 228
  CONTAINS
  INTEGER FUNCTION zdf_osm_alloc()
    ALLOCATE(ghamu(jpi, jpj, jpk), ghamv(jpi, jpj, jpk), ghamt(jpi, jpj, jpk), ghams(jpi, jpj, jpk), hbl(jpi, jpj), hbli(jpi, jpj), dstokes(jpi, jpj), etmean(jpi, jpj, jpk), STAT = zdf_osm_alloc)
    IF (zdf_osm_alloc /= 0) CALL ctl_warn('zdf_osm_alloc: failed to allocate zdf_osm arrays')
    IF (lk_mpp) CALL mpp_sum(zdf_osm_alloc)
  END FUNCTION zdf_osm_alloc
  SUBROUTINE zdf_osm(kt, p_avm, p_avt)
    INTEGER, INTENT(IN   ) :: kt
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: p_avm, p_avt
    INTEGER :: ji, jj, jk
    INTEGER :: ikbot, jkmax, jkm1, jkp2
    REAL(KIND = wp) :: ztx, zty, zflageos, zstabl, zbuofdep, zucube
    REAL(KIND = wp) :: zbeta, zthermal
    REAL(KIND = wp) :: zehat, zeta, zhrib, zsig, zscale, zwst, zws, zwm
    REAL(KIND = wp) :: zwsun, zwmun, zcons, zconm, zwcons, zwconm
    REAL(KIND = wp) :: zsr, zbw, ze, zb, zd, zc, zaw, za, zb1, za1, zkw, zk0, zcomp, zrhd, zrhdr, zbvzed
    INTEGER :: jm
    REAL(KIND = wp) :: zr1, zr2, zr3, zr4, zrhop
    REAL(KIND = wp) :: zflag, zrn2, zdep21, zdep32, zdep43
    REAL(KIND = wp) :: zesh2, zri, zfri
    REAL(KIND = wp) :: zdelta, zdelta2, zdzup, zdzdn, zdzh, zvath, zgat1, zdat1, zkm1m, zkm1t
    REAL(KIND = wp) :: zt, zs, zu, zv, zrh
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zrad0
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zradh
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zradav
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zustar
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwstrl
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zvstr
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwstrc
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zuw0
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zvw0
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwth0
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zws0
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwb0
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwthav
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwsav
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwbav
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwb_ent
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zustke
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zla
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zcos_wind
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zsin_wind
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zhol
    LOGICAL, DIMENSION(:, :), ALLOCATABLE :: lconv
    INTEGER, DIMENSION(jpi, jpj) :: ibld
    INTEGER, DIMENSION(jpi, jpj) :: imld
    REAL(KIND = wp) :: ztgrad, zsgrad, zbgrad
    REAL(KIND = wp) :: zugrad, zvgrad
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zhbl
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zhml
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zdh
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zdhdt
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zt_bl, zs_bl, zu_bl, zv_bl, zrh_bl
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zt_ml, zs_ml, zu_ml, zv_ml, zrh_ml
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zdt_bl, zds_bl, zdu_bl, zdv_bl, zdrh_bl, zdb_bl
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zdt_ml, zds_ml, zdu_ml, zdv_ml, zdrh_ml, zdb_ml
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zwth_ent, zws_ent
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zuw_bse, zvw_bse
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdtdz_pyc
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdsdz_pyc
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdbdz_pyc
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdudz_pyc
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdvdz_pyc
    REAL(KIND = wp) :: zl_c, zl_l, zl_eps
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zdifml_sc, zvisml_sc, zdifpyc_sc, zvispyc_sc, zbeta_d_sc, zbeta_v_sc
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zsc_wth_1, zsc_ws_1
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zsc_uw_1, zsc_uw_2, zsc_vw_1, zsc_vw_2
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zhbl_t
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: z3du
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: z3dv
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zrimix
    INTEGER :: inhml
    INTEGER :: i_lconv_alloc
    REAL(KIND = wp) :: znd, znd_d, zznd_ml, zznd_pyc, zznd_d
    REAL(KIND = wp) :: ztemp, zari, zpert, zzdhdt, zdb
    REAL(KIND = wp) :: zthick, zz0, zz1
    REAL(KIND = wp) :: zvel_max, zhbl_s
    REAL(KIND = wp) :: zfac
    REAL(KIND = wp) :: zus_x, zus_y
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zviscos
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zdiffut
    INTEGER :: ikt
    ALLOCATE(lconv(jpi, jpj), STAT = i_lconv_alloc)
    IF (i_lconv_alloc /= 0) CALL ctl_warn('zdf_osm: failed to allocate lconv')
    !$ACC KERNELS
    ibld(:, :) = 0
    imld(:, :) = 0
    zrad0(:, :) = 0._wp
    zradh(:, :) = 0._wp
    zradav(:, :) = 0._wp
    zustar(:, :) = 0._wp
    zwstrl(:, :) = 0._wp
    zvstr(:, :) = 0._wp
    zwstrc(:, :) = 0._wp
    zuw0(:, :) = 0._wp
    zvw0(:, :) = 0._wp
    zwth0(:, :) = 0._wp
    zws0(:, :) = 0._wp
    zwb0(:, :) = 0._wp
    zwthav(:, :) = 0._wp
    zwsav(:, :) = 0._wp
    zwbav(:, :) = 0._wp
    zwb_ent(:, :) = 0._wp
    zustke(:, :) = 0._wp
    zla(:, :) = 0._wp
    zcos_wind(:, :) = 0._wp
    zsin_wind(:, :) = 0._wp
    zhol(:, :) = 0._wp
    lconv(:, :) = .FALSE.
    zhbl(:, :) = 1._wp
    zhml(:, :) = 1._wp
    zdh(:, :) = 1._wp
    zdhdt(:, :) = 0._wp
    zt_bl(:, :) = 0._wp
    zs_bl(:, :) = 0._wp
    zu_bl(:, :) = 0._wp
    zv_bl(:, :) = 0._wp
    zrh_bl(:, :) = 0._wp
    zt_ml(:, :) = 0._wp
    zs_ml(:, :) = 0._wp
    zu_ml(:, :) = 0._wp
    zv_ml(:, :) = 0._wp
    zrh_ml(:, :) = 0._wp
    zdt_bl(:, :) = 0._wp
    zds_bl(:, :) = 0._wp
    zdu_bl(:, :) = 0._wp
    zdv_bl(:, :) = 0._wp
    zdrh_bl(:, :) = 0._wp
    zdb_bl(:, :) = 0._wp
    zdt_ml(:, :) = 0._wp
    zds_ml(:, :) = 0._wp
    zdu_ml(:, :) = 0._wp
    zdv_ml(:, :) = 0._wp
    zdrh_ml(:, :) = 0._wp
    zdb_ml(:, :) = 0._wp
    zwth_ent(:, :) = 0._wp
    zws_ent(:, :) = 0._wp
    zuw_bse(:, :) = 0._wp
    zvw_bse(:, :) = 0._wp
    zdtdz_pyc(:, :, :) = 0._wp
    zdsdz_pyc(:, :, :) = 0._wp
    zdbdz_pyc(:, :, :) = 0._wp
    zdudz_pyc(:, :, :) = 0._wp
    zdvdz_pyc(:, :, :) = 0._wp
    zdifml_sc(:, :) = 0._wp
    zvisml_sc(:, :) = 0._wp
    zdifpyc_sc(:, :) = 0._wp
    zvispyc_sc(:, :) = 0._wp
    zbeta_d_sc(:, :) = 0._wp
    zbeta_v_sc(:, :) = 0._wp
    zsc_wth_1(:, :) = 0._wp
    zsc_ws_1(:, :) = 0._wp
    zsc_uw_1(:, :) = 0._wp
    zsc_uw_2(:, :) = 0._wp
    zsc_vw_1(:, :) = 0._wp
    zsc_vw_2(:, :) = 0._wp
    zhbl_t(:, :) = 0._wp
    zdhdt(:, :) = 0._wp
    zdiffut(:, :, :) = 0._wp
    zviscos(:, :, :) = 0._wp
    ghamt(:, :, :) = 0._wp
    ghams(:, :, :) = 0._wp
    ghamu(:, :, :) = 0._wp
    ghamv(:, :, :) = 0._wp
    zz0 = rn_abs
    zz1 = 1. - rn_abs
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zrad0(ji, jj) = qsr(ji, jj) * r1_rau0_rcp
        zradh(ji, jj) = zrad0(ji, jj) * (zz0 * EXP(- hbl(ji, jj) / rn_si0) + zz1 * EXP(- hbl(ji, jj) / rn_si1))
        zradav(ji, jj) = zrad0(ji, jj) * (zz0 * (1.0 - EXP(- hbl(ji, jj) / rn_si0)) * rn_si0 + zz1 * (1.0 - EXP(- hbl(ji, jj) / rn_si1)) * rn_si1) / hbl(ji, jj)
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zthermal = rab_n(ji, jj, 1, jp_tem)
        zbeta = rab_n(ji, jj, 1, jp_sal)
        zwth0(ji, jj) = - qns(ji, jj) * r1_rau0_rcp * tmask(ji, jj, 1)
        zws0(ji, jj) = - ((emp(ji, jj) - rnf(ji, jj)) * tsn(ji, jj, 1, jp_sal) + sfx(ji, jj)) * r1_rau0 * tmask(ji, jj, 1)
        zwb0(ji, jj) = grav * zthermal * zwth0(ji, jj) - grav * zbeta * zws0(ji, jj)
        zwthav(ji, jj) = 0.5 * zwth0(ji, jj) - (0.5 * (zrad0(ji, jj) + zradh(ji, jj)) - zradav(ji, jj))
        zwsav(ji, jj) = 0.5 * zws0(ji, jj)
        zwbav(ji, jj) = grav * zthermal * zwthav(ji, jj) - grav * zbeta * zwsav(ji, jj)
        zuw0(ji, jj) = - utau(ji, jj) * r1_rau0 * tmask(ji, jj, 1)
        zvw0(ji, jj) = - vtau(ji, jj) * r1_rau0 * tmask(ji, jj, 1)
        zustar(ji, jj) = MAX(SQRT(SQRT(zuw0(ji, jj) * zuw0(ji, jj) + zvw0(ji, jj) * zvw0(ji, jj))), 1.0E-8)
        zcos_wind(ji, jj) = - zuw0(ji, jj) / (zustar(ji, jj) * zustar(ji, jj))
        zsin_wind(ji, jj) = - zvw0(ji, jj) / (zustar(ji, jj) * zustar(ji, jj))
      END DO
    END DO
    !$ACC END KERNELS
    SELECT CASE (nn_osm_wave)
    CASE (0)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zus_x = zcos_wind(ji, jj) * zustar(ji, jj) / 0.3 ** 2
          zus_y = zsin_wind(ji, jj) * zustar(ji, jj) / 0.3 ** 2
          zustke(ji, jj) = MAX(SQRT(zus_x * zus_x + zus_y * zus_y), 1.0E-8)
        END DO
      END DO
      !$ACC END KERNELS
    CASE (1)
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zustke(ji, jj) = MAX(0.016 * wndm(ji, jj), 1.0E-8)
          dstokes(ji, jj) = 0.12 * wndm(ji, jj) ** 2 / grav
        END DO
      END DO
      !$ACC END KERNELS
    CASE (2)
      !$ACC KERNELS
      zfac = 2.0_wp * rpi / 16.0_wp
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          zustke(ji, jj) = MAX(1.0 * (zcos_wind(ji, jj) * ut0sd(ji, jj) + zsin_wind(ji, jj) * vt0sd(ji, jj)), zustar(ji, jj) / (0.45 * 0.45))
          dstokes(ji, jj) = MAX(zfac * hsw(ji, jj) * hsw(ji, jj) / (MAX(zustke(ji, jj) * wmp(ji, jj), 1.0E-7)), 5.0E-1)
        END DO
      END DO
      !$ACC END KERNELS
    END SELECT
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zwstrl(ji, jj) = (zustar(ji, jj) * zustar(ji, jj) * zustke(ji, jj)) ** pthird
        zwstrl(ji, jj) = zwstrl(ji, jj) * (1.12 * (1.0 - (1.0 - EXP(- hbl(ji, jj) / dstokes(ji, jj))) * dstokes(ji, jj) / hbl(ji, jj))) ** pthird * (1.0 - EXP(- 15.0 * dstokes(ji, jj) / hbl(ji, jj)))
        zla(ji, jj) = SQRT(zustar(ji, jj) / zwstrl(ji, jj)) ** 3
        zvstr(ji, jj) = (zwstrl(ji, jj) ** 3 + (1.0 - EXP(- 0.5 * zla(ji, jj) ** 2)) * zustar(ji, jj) * zustar(ji, jj) * zustar(ji, jj)) ** pthird
        IF (zla(ji, jj) >= 0.45) zla(ji, jj) = 0.45
        IF (zwbav(ji, jj) > 0.0) THEN
          zwstrc(ji, jj) = (2.0 * zwbav(ji, jj) * 0.9 * hbl(ji, jj)) ** pthird
          zhol(ji, jj) = - 0.9 * hbl(ji, jj) * 2.0 * zwbav(ji, jj) / (zvstr(ji, jj) ** 3 + epsln)
          lconv(ji, jj) = .TRUE.
        ELSE
          zhol(ji, jj) = - hbl(ji, jj) * 2.0 * zwbav(ji, jj) / (zvstr(ji, jj) ** 3 + epsln)
          lconv(ji, jj) = .FALSE.
        END IF
      END DO
    END DO
    hbl(:, :) = MAX(hbl(:, :), gdepw_n(:, :, 3))
    ibld(:, :) = 3
    DO jk = 4, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          IF (hbl(ji, jj) >= gdepw_n(ji, jj, jk)) THEN
            ibld(ji, jj) = MIN(mbkt(ji, jj), jk)
          END IF
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        !$ACC KERNELS
        zthermal = rab_n(ji, jj, 1, jp_tem)
        zbeta = rab_n(ji, jj, 1, jp_sal)
        zt = 0._wp
        zs = 0._wp
        zu = 0._wp
        zv = 0._wp
        zthick = 0._wp
        DO jm = 2, ibld(ji, jj)
          zthick = zthick + e3t_n(ji, jj, jm)
          zt = zt + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_tem)
          zs = zs + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_sal)
          zu = zu + e3t_n(ji, jj, jm) * (ub(ji, jj, jm) + ub(ji - 1, jj, jm)) / MAX(1., umask(ji, jj, jm) + umask(ji - 1, jj, jm))
          zv = zv + e3t_n(ji, jj, jm) * (vb(ji, jj, jm) + vb(ji, jj - 1, jm)) / MAX(1., vmask(ji, jj, jm) + vmask(ji, jj - 1, jm))
        END DO
        zt_bl(ji, jj) = zt / zthick
        zs_bl(ji, jj) = zs / zthick
        zu_bl(ji, jj) = zu / zthick
        zv_bl(ji, jj) = zv / zthick
        zdt_bl(ji, jj) = zt_bl(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_tem)
        zds_bl(ji, jj) = zs_bl(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_sal)
        zdu_bl(ji, jj) = zu_bl(ji, jj) - (ub(ji, jj, ibld(ji, jj)) + ub(ji - 1, jj, ibld(ji, jj))) / MAX(1., umask(ji, jj, ibld(ji, jj)) + umask(ji - 1, jj, ibld(ji, jj)))
        zdv_bl(ji, jj) = zv_bl(ji, jj) - (vb(ji, jj, ibld(ji, jj)) + vb(ji, jj - 1, ibld(ji, jj))) / MAX(1., vmask(ji, jj, ibld(ji, jj)) + vmask(ji, jj - 1, ibld(ji, jj)))
        zdb_bl(ji, jj) = grav * zthermal * zdt_bl(ji, jj) - grav * zbeta * zds_bl(ji, jj)
        !$ACC END KERNELS
        IF (lconv(ji, jj)) THEN
          zwb_ent(ji, jj) = - (2.0 * 0.2 * zwbav(ji, jj) + 0.135 * zla(ji, jj) * zwstrl(ji, jj) ** 3 / hbl(ji, jj))
          zvel_max = - (1.0 + 1.0 * (zwstrl(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird * rn_rdt / hbl(ji, jj)) * zwb_ent(ji, jj) / (zwstrl(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird
          zzdhdt = - zwb_ent(ji, jj) / (zvel_max + MAX(zdb_bl(ji, jj), 0.0))
        ELSE
          zzdhdt = 0.32 * (hbli(ji, jj) / hbl(ji, jj) - 1.0) * zwstrl(ji, jj) ** 3 / hbli(ji, jj) + ((0.32 / 3.0) * EXP(- 2.5 * (hbli(ji, jj) / hbl(ji, jj) - 1.0)) - (0.32 / 3.0 - 0.135 * zla(ji, jj)) * EXP(- 12.5 * (hbli(ji, jj) / hbl(ji, jj)))) * zwstrl(ji, jj) ** 3 / hbli(ji, jj)
          zzdhdt = zzdhdt + zwbav(ji, jj)
          IF (zzdhdt < 0._wp) THEN
            zpert = 2.0 * (1.0 + 2.0 * zwstrl(ji, jj) * rn_rdt / hbl(ji, jj)) * zwstrl(ji, jj) ** 2 / hbl(ji, jj)
          ELSE
            zpert = 2.0 * (1.0 + 2.0 * zwstrl(ji, jj) * rn_rdt / hbl(ji, jj)) * zwstrl(ji, jj) ** 2 / hbl(ji, jj) + MAX(zdb_bl(ji, jj), 0.0)
          END IF
          zzdhdt = 2.0 * zzdhdt / zpert
        END IF
        zdhdt(ji, jj) = zzdhdt
      END DO
    END DO
    !$ACC KERNELS
    imld = ibld
    ibld(:, :) = 3
    zhbl_t(:, :) = hbl(:, :) + (zdhdt(:, :) - wn(ji, jj, ibld(ji, jj))) * rn_rdt
    zhbl_t(:, :) = MIN(zhbl_t(:, :), ht_n(:, :))
    zdhdt(:, :) = MIN(zdhdt(:, :), (zhbl_t(:, :) - hbl(:, :)) / rn_rdt + wn(ji, jj, ibld(ji, jj)))
    DO jk = 4, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          IF (zhbl_t(ji, jj) >= gdepw_n(ji, jj, jk)) THEN
            ibld(ji, jj) = MIN(mbkt(ji, jj), jk)
          END IF
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (ibld(ji, jj) - imld(ji, jj) > 1) THEN
          zhbl_s = hbl(ji, jj)
          jm = imld(ji, jj)
          zthermal = rab_n(ji, jj, 1, jp_tem)
          zbeta = rab_n(ji, jj, 1, jp_sal)
          IF (lconv(ji, jj)) THEN
            zvel_max = - (1.0 + 1.0 * (zvstr(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird * rn_rdt / hbl(ji, jj)) * zwb_ent(ji, jj) / (zvstr(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird
            DO jk = imld(ji, jj), ibld(ji, jj)
              zdb = MAX(grav * (zthermal * (zt_bl(ji, jj) - tsn(ji, jj, jm, jp_tem)) - zbeta * (zs_bl(ji, jj) - tsn(ji, jj, jm, jp_sal))), 0.0) + zvel_max
              zhbl_s = zhbl_s + MIN(- zwb_ent(ji, jj) / zdb * rn_rdt / FLOAT(ibld(ji, jj) - imld(ji, jj)), e3w_n(ji, jj, jk))
              zhbl_s = MIN(zhbl_s, ht_n(ji, jj))
              IF (zhbl_s >= gdepw_n(ji, jj, jm + 1)) jm = jm + 1
            END DO
            hbl(ji, jj) = zhbl_s
            ibld(ji, jj) = jm
            hbli(ji, jj) = hbl(ji, jj)
          ELSE
            !$ACC KERNELS
            DO jk = imld(ji, jj), ibld(ji, jj)
              zdb = MAX(grav * (zthermal * (zt_bl(ji, jj) - tsn(ji, jj, jm, jp_tem)) - zbeta * (zs_bl(ji, jj) - tsn(ji, jj, jm, jp_sal))), 0.0) + 2.0 * zwstrl(ji, jj) ** 2 / zhbl_s
              zhbl_s = zhbl_s + (0.32 * (hbli(ji, jj) / zhbl_s - 1.0) * zwstrl(ji, jj) ** 3 / hbli(ji, jj) + ((0.32 / 3.0) * EXP(- 2.5 * (hbli(ji, jj) / zhbl_s - 1.0)) - (0.32 / 3.0 - 0.0485) * EXP(- 12.5 * (hbli(ji, jj) / zhbl_s))) * zwstrl(ji, jj) ** 3 / hbli(ji, jj)) / zdb * e3w_n(ji, jj, jk) / zdhdt(ji, jj)
              zhbl_s = MIN(zhbl_s, ht_n(ji, jj))
              IF (zhbl_s >= gdepw_n(ji, jj, jm)) jm = jm + 1
            END DO
            hbl(ji, jj) = MAX(zhbl_s, gdepw_n(ji, jj, 3))
            ibld(ji, jj) = MAX(jm, 3)
            IF (hbl(ji, jj) > hbli(ji, jj)) hbli(ji, jj) = hbl(ji, jj)
            !$ACC END KERNELS
          END IF
        ELSE
          hbl(ji, jj) = zhbl_t(ji, jj)
          IF (lconv(ji, jj)) THEN
            hbli(ji, jj) = hbl(ji, jj)
          ELSE
            hbl(ji, jj) = MAX(hbl(ji, jj), gdepw_n(ji, jj, 3))
            IF (hbl(ji, jj) > hbli(ji, jj)) hbli(ji, jj) = hbl(ji, jj)
          END IF
        END IF
        zhbl(ji, jj) = gdepw_n(ji, jj, ibld(ji, jj))
      END DO
    END DO
    !$ACC KERNELS
    dstokes(:, :) = MIN(dstokes(:, :), hbl(:, :) / 3.)
    !$ACC END KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        !$ACC KERNELS
        zthermal = rab_n(ji, jj, 1, jp_tem)
        zbeta = rab_n(ji, jj, 1, jp_sal)
        zt = 0._wp
        zs = 0._wp
        zu = 0._wp
        zv = 0._wp
        zthick = 0._wp
        DO jm = 2, ibld(ji, jj)
          zthick = zthick + e3t_n(ji, jj, jm)
          zt = zt + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_tem)
          zs = zs + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_sal)
          zu = zu + e3t_n(ji, jj, jm) * (ub(ji, jj, jm) + ub(ji - 1, jj, jm)) / MAX(1., umask(ji, jj, jm) + umask(ji - 1, jj, jm))
          zv = zv + e3t_n(ji, jj, jm) * (vb(ji, jj, jm) + vb(ji, jj - 1, jm)) / MAX(1., vmask(ji, jj, jm) + vmask(ji, jj - 1, jm))
        END DO
        zt_bl(ji, jj) = zt / zthick
        zs_bl(ji, jj) = zs / zthick
        zu_bl(ji, jj) = zu / zthick
        zv_bl(ji, jj) = zv / zthick
        zdt_bl(ji, jj) = zt_bl(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_tem)
        zds_bl(ji, jj) = zs_bl(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_sal)
        zdu_bl(ji, jj) = zu_bl(ji, jj) - (ub(ji, jj, ibld(ji, jj)) + ub(ji - 1, jj, ibld(ji, jj))) / MAX(1., umask(ji, jj, ibld(ji, jj)) + umask(ji - 1, jj, ibld(ji, jj)))
        zdv_bl(ji, jj) = zv_bl(ji, jj) - (vb(ji, jj, ibld(ji, jj)) + vb(ji, jj - 1, ibld(ji, jj))) / MAX(1., vmask(ji, jj, ibld(ji, jj)) + vmask(ji, jj - 1, ibld(ji, jj)))
        zdb_bl(ji, jj) = grav * zthermal * zdt_bl(ji, jj) - grav * zbeta * zds_bl(ji, jj)
        zhbl(ji, jj) = gdepw_n(ji, jj, ibld(ji, jj))
        !$ACC END KERNELS
        IF (lconv(ji, jj)) THEN
          IF (zdb_bl(ji, jj) > 0._wp) THEN
            IF ((zwstrc(ji, jj) / zvstr(ji, jj)) ** 3 <= 0.5) THEN
              zari = 4.5 * (zvstr(ji, jj) ** 2) / (zdb_bl(ji, jj) * zhbl(ji, jj)) + 0.01
            ELSE
              zari = 4.5 * (zwstrc(ji, jj) ** 2) / (zdb_bl(ji, jj) * zhbl(ji, jj)) + 0.01
            END IF
            IF (zari > 0.2) THEN
              zari = 0.2
              zwb_ent(ji, jj) = 0._wp
            END IF
            inhml = MAX(INT(zari * zhbl(ji, jj) / e3t_n(ji, jj, ibld(ji, jj))), 1)
            imld(ji, jj) = MAX(ibld(ji, jj) - inhml, 1)
            zhml(ji, jj) = gdepw_n(ji, jj, imld(ji, jj))
            zdh(ji, jj) = zhbl(ji, jj) - zhml(ji, jj)
          ELSE
            imld(ji, jj) = ibld(ji, jj) - 1
            zhml(ji, jj) = gdepw_n(ji, jj, imld(ji, jj))
            zdh(ji, jj) = zhbl(ji, jj) - zhml(ji, jj)
          END IF
        ELSE
          IF (zdhdt(ji, jj) >= 0.0) THEN
            IF (zdb_bl(ji, jj) > 0._wp) THEN
              zari = MIN(4.5 * (zvstr(ji, jj) ** 2) / (zdb_bl(ji, jj) * zhbl(ji, jj)) + 0.01, 0.2)
              inhml = MAX(INT(zari * zhbl(ji, jj) / e3t_n(ji, jj, ibld(ji, jj))), 1)
              imld(ji, jj) = MAX(ibld(ji, jj) - inhml, 1)
              zhml(ji, jj) = gdepw_n(ji, jj, imld(ji, jj))
              zdh(ji, jj) = zhbl(ji, jj) - zhml(ji, jj)
            ELSE
              imld(ji, jj) = ibld(ji, jj) - 1
              zhml(ji, jj) = gdepw_n(ji, jj, imld(ji, jj))
              zdh(ji, jj) = zhbl(ji, jj) - zhml(ji, jj)
            END IF
          ELSE
            imld(ji, jj) = ibld(ji, jj)
            zhml(ji, jj) = zhbl(ji, jj)
            zdh(ji, jj) = 0._wp
          END IF
        END IF
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        zthermal = rab_n(ji, jj, 1, jp_tem)
        zbeta = rab_n(ji, jj, 1, jp_sal)
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          zt = 0._wp
          zs = 0._wp
          zu = 0._wp
          zv = 0._wp
          zthick = 0._wp
          DO jm = 2, imld(ji, jj)
            zthick = zthick + e3t_n(ji, jj, jm)
            zt = zt + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_tem)
            zs = zs + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_sal)
            zu = zu + e3t_n(ji, jj, jm) * (ub(ji, jj, jm) + ub(ji - 1, jj, jm)) / MAX(1., umask(ji, jj, jm) + umask(ji - 1, jj, jm))
            zv = zv + e3t_n(ji, jj, jm) * (vb(ji, jj, jm) + vb(ji, jj - 1, jm)) / MAX(1., vmask(ji, jj, jm) + vmask(ji, jj - 1, jm))
          END DO
          zt_ml(ji, jj) = zt / zthick
          zs_ml(ji, jj) = zs / zthick
          zu_ml(ji, jj) = zu / zthick
          zv_ml(ji, jj) = zv / zthick
          zdt_ml(ji, jj) = zt_ml(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_tem)
          zds_ml(ji, jj) = zs_ml(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_sal)
          zdu_ml(ji, jj) = zu_ml(ji, jj) - (ub(ji, jj, ibld(ji, jj)) + ub(ji - 1, jj, ibld(ji, jj))) / MAX(1., umask(ji, jj, ibld(ji, jj)) + umask(ji - 1, jj, ibld(ji, jj)))
          zdv_ml(ji, jj) = zv_ml(ji, jj) - (vb(ji, jj, ibld(ji, jj)) + vb(ji, jj - 1, ibld(ji, jj))) / MAX(1., vmask(ji, jj, ibld(ji, jj)) + vmask(ji, jj - 1, ibld(ji, jj)))
          zdb_ml(ji, jj) = grav * zthermal * zdt_ml(ji, jj) - grav * zbeta * zds_ml(ji, jj)
          !$ACC END KERNELS
        ELSE
          IF (zdhdt(ji, jj) >= 0._wp) THEN
            !$ACC KERNELS
            zt = 0._wp
            zs = 0._wp
            zu = 0._wp
            zv = 0._wp
            zthick = 0._wp
            DO jm = 2, imld(ji, jj)
              zthick = zthick + e3t_n(ji, jj, jm)
              zt = zt + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_tem)
              zs = zs + e3t_n(ji, jj, jm) * tsn(ji, jj, jm, jp_sal)
              zu = zu + e3t_n(ji, jj, jm) * (ub(ji, jj, jm) + ub(ji - 1, jj, jm)) / MAX(1., umask(ji, jj, jm) + umask(ji - 1, jj, jm))
              zv = zv + e3t_n(ji, jj, jm) * (vb(ji, jj, jm) + vb(ji, jj - 1, jm)) / MAX(1., vmask(ji, jj, jm) + vmask(ji, jj - 1, jm))
            END DO
            zt_ml(ji, jj) = zt / zthick
            zs_ml(ji, jj) = zs / zthick
            zu_ml(ji, jj) = zu / zthick
            zv_ml(ji, jj) = zv / zthick
            zdt_ml(ji, jj) = zt_ml(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_tem)
            zds_ml(ji, jj) = zs_ml(ji, jj) - tsn(ji, jj, ibld(ji, jj), jp_sal)
            zdu_ml(ji, jj) = zu_ml(ji, jj) - (ub(ji, jj, ibld(ji, jj)) + ub(ji - 1, jj, ibld(ji, jj))) / MAX(1., umask(ji, jj, ibld(ji, jj)) + umask(ji - 1, jj, ibld(ji, jj)))
            zdv_ml(ji, jj) = zv_ml(ji, jj) - (vb(ji, jj, ibld(ji, jj)) + vb(ji, jj - 1, ibld(ji, jj))) / MAX(1., vmask(ji, jj, ibld(ji, jj)) + vmask(ji, jj - 1, ibld(ji, jj)))
            zdb_ml(ji, jj) = grav * zthermal * zdt_ml(ji, jj) - grav * zbeta * zds_ml(ji, jj)
            !$ACC END KERNELS
          END IF
        END IF
      END DO
    END DO
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        ztemp = zu_ml(ji, jj)
        zu_ml(ji, jj) = zu_ml(ji, jj) * zcos_wind(ji, jj) + zv_ml(ji, jj) * zsin_wind(ji, jj)
        zv_ml(ji, jj) = zv_ml(ji, jj) * zcos_wind(ji, jj) - ztemp * zsin_wind(ji, jj)
        ztemp = zdu_ml(ji, jj)
        zdu_ml(ji, jj) = zdu_ml(ji, jj) * zcos_wind(ji, jj) + zdv_ml(ji, jj) * zsin_wind(ji, jj)
        zdv_ml(ji, jj) = zdv_ml(ji, jj) * zsin_wind(ji, jj) - ztemp * zsin_wind(ji, jj)
        ztemp = zu_bl(ji, jj)
        zu_bl = zu_bl(ji, jj) * zcos_wind(ji, jj) + zv_bl(ji, jj) * zsin_wind(ji, jj)
        zv_bl(ji, jj) = zv_bl(ji, jj) * zcos_wind(ji, jj) - ztemp * zsin_wind(ji, jj)
        ztemp = zdu_bl(ji, jj)
        zdu_bl(ji, jj) = zdu_bl(ji, jj) * zcos_wind(ji, jj) + zdv_bl(ji, jj) * zsin_wind(ji, jj)
        zdv_bl(ji, jj) = zdv_bl(ji, jj) * zsin_wind(ji, jj) - ztemp * zsin_wind(ji, jj)
      END DO
    END DO
    zuw_bse = 0._wp
    zvw_bse = 0._wp
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          IF (zdb_bl(ji, jj) > 0._wp) THEN
            zwth_ent(ji, jj) = zwb_ent(ji, jj) * zdt_ml(ji, jj) / (zdb_ml(ji, jj) + epsln)
            zws_ent(ji, jj) = zwb_ent(ji, jj) * zds_ml(ji, jj) / (zdb_ml(ji, jj) + epsln)
          END IF
        ELSE
          zwth_ent(ji, jj) = - 2.0 * zwthav(ji, jj) * ((1.0 - 0.8) - (1.0 - 0.8) ** (3.0 / 2.0))
          zws_ent(ji, jj) = - 2.0 * zwsav(ji, jj) * ((1.0 - 0.8) - (1.0 - 0.8) ** (3.0 / 2.0))
        END IF
      END DO
    END DO
    !$ACC END KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          IF (zdb_bl(ji, jj) > 0._wp) THEN
            !$ACC KERNELS
            ztgrad = (zdt_ml(ji, jj) / zdh(ji, jj))
            zsgrad = (zds_ml(ji, jj) / zdh(ji, jj))
            zbgrad = (zdb_ml(ji, jj) / zdh(ji, jj))
            DO jk = 2, ibld(ji, jj)
              znd = - (gdepw_n(ji, jj, jk) - zhml(ji, jj)) / zdh(ji, jj)
              zdtdz_pyc(ji, jj, jk) = ztgrad * EXP(- 1.75 * (znd + 0.75) ** 2)
              zdbdz_pyc(ji, jj, jk) = zbgrad * EXP(- 1.75 * (znd + 0.75) ** 2)
              zdsdz_pyc(ji, jj, jk) = zsgrad * EXP(- 1.75 * (znd + 0.75) ** 2)
            END DO
            !$ACC END KERNELS
          END IF
        ELSE
          IF (zdhdt(ji, jj) >= 0.0) THEN
            IF (zdb_bl(ji, jj) > 0._wp) THEN
              IF (zhol(ji, jj) >= 0.5) THEN
                !$ACC KERNELS
                ztgrad = zdt_bl(ji, jj) / zhbl(ji, jj)
                zsgrad = zds_bl(ji, jj) / zhbl(ji, jj)
                zbgrad = zdb_bl(ji, jj) / zhbl(ji, jj)
                DO jk = 2, ibld(ji, jj)
                  znd = gdepw_n(ji, jj, jk) / zhbl(ji, jj)
                  zdtdz_pyc(ji, jj, jk) = ztgrad * EXP(- 15.0 * (znd - 0.9) ** 2)
                  zdbdz_pyc(ji, jj, jk) = zbgrad * EXP(- 15.0 * (znd - 0.9) ** 2)
                  zdsdz_pyc(ji, jj, jk) = zsgrad * EXP(- 15.0 * (znd - 0.9) ** 2)
                END DO
                !$ACC END KERNELS
              ELSE
                !$ACC KERNELS
                ztgrad = zdt_bl(ji, jj) / zdh(ji, jj)
                zsgrad = zds_bl(ji, jj) / zdh(ji, jj)
                zbgrad = zdb_bl(ji, jj) / zdh(ji, jj)
                DO jk = 2, ibld(ji, jj)
                  znd = - (gdepw_n(ji, jj, jk) - zhml(ji, jj)) / zdh(ji, jj)
                  zdtdz_pyc(ji, jj, jk) = ztgrad * EXP(- 1.75 * (znd + 0.75) ** 2)
                  zdbdz_pyc(ji, jj, jk) = zbgrad * EXP(- 1.75 * (znd + 0.75) ** 2)
                  zdsdz_pyc(ji, jj, jk) = zsgrad * EXP(- 1.75 * (znd + 0.75) ** 2)
                END DO
                !$ACC END KERNELS
              END IF
            END IF
          END IF
        END IF
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          zugrad = (zdu_ml(ji, jj) / zdh(ji, jj)) + 0.275 * zustar(ji, jj) * zustar(ji, jj) / ((zwstrl(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird * zhml(ji, jj)) / zla(ji, jj) ** (8.0 / 3.0)
          zvgrad = (zdv_ml(ji, jj) / zdh(ji, jj)) + 3.5 * ff_t(ji, jj) * zustke(ji, jj) / (zwstrl(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird
          DO jk = 2, ibld(ji, jj) - 1
            znd = - (gdepw_n(ji, jj, jk) - zhml(ji, jj)) / zdh(ji, jj)
            zdudz_pyc(ji, jj, jk) = zugrad * EXP(- 1.75 * (znd + 0.75) ** 2)
            zdvdz_pyc(ji, jj, jk) = zvgrad * EXP(- 1.75 * (znd + 0.75) ** 2)
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          zugrad = 3.25 * zdu_bl(ji, jj) / zhbl(ji, jj)
          zvgrad = 2.75 * zdv_bl(ji, jj) / zhbl(ji, jj)
          DO jk = 2, ibld(ji, jj)
            znd = gdepw_n(ji, jj, jk) / zhbl(ji, jj)
            IF (znd < 1.0) THEN
              zdudz_pyc(ji, jj, jk) = zugrad * EXP(- 40.0 * (znd - 1.0) ** 2)
            ELSE
              zdudz_pyc(ji, jj, jk) = zugrad * EXP(- 20.0 * (znd - 1.0) ** 2)
            END IF
            zdvdz_pyc(ji, jj, jk) = zvgrad * EXP(- 20.0 * (znd - 0.85) ** 2)
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          zdifml_sc(ji, jj) = zhml(ji, jj) * (zvstr(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird
          zvisml_sc(ji, jj) = zdifml_sc(ji, jj)
          zdifpyc_sc(ji, jj) = 0.165 * (zvstr(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird * zdh(ji, jj)
          zvispyc_sc(ji, jj) = 0.142 * (zvstr(ji, jj) ** 3 + 0.5 * zwstrc(ji, jj) ** 3) ** pthird * zdh(ji, jj)
          zbeta_d_sc(ji, jj) = 1.0 - (0.165 / 0.8 * zdh(ji, jj) / zhbl(ji, jj)) ** p2third
          zbeta_v_sc(ji, jj) = 1.0 - 2.0 * (0.142 / 0.375) * zdh(ji, jj) / zhml(ji, jj)
        ELSE
          zdifml_sc(ji, jj) = zvstr(ji, jj) * zhbl(ji, jj) * EXP(- (zhol(ji, jj) / 0.6_wp) ** 2)
          zvisml_sc(ji, jj) = zvstr(ji, jj) * zhbl(ji, jj) * EXP(- (zhol(ji, jj) / 0.6_wp) ** 2)
        END IF
      END DO
    END DO
    !$ACC END KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, imld(ji, jj)
            zznd_ml = gdepw_n(ji, jj, jk) / zhml(ji, jj)
            zdiffut(ji, jj, jk) = 0.8 * zdifml_sc(ji, jj) * zznd_ml * (1.0 - zbeta_d_sc(ji, jj) * zznd_ml) ** 1.5
            zviscos(ji, jj, jk) = 0.375 * zvisml_sc(ji, jj) * zznd_ml * (1.0 - zbeta_v_sc(ji, jj) * zznd_ml) * (1.0 - 0.5 * zznd_ml ** 2)
          END DO
          !$ACC END KERNELS
          IF (zdh(ji, jj) > 0._wp) THEN
            !$ACC KERNELS
            DO jk = imld(ji, jj) + 1, ibld(ji, jj)
              zznd_pyc = - (gdepw_n(ji, jj, jk) - zhml(ji, jj)) / zdh(ji, jj)
              zdiffut(ji, jj, jk) = zdifpyc_sc(ji, jj) * (1.0 + zznd_pyc)
              zviscos(ji, jj, jk) = zvispyc_sc(ji, jj) * (1.0 + zznd_pyc)
            END DO
            !$ACC END KERNELS
          END IF
          zdiffut(ji, jj, ibld(ji, jj)) = zdhdt(ji, jj) * e3t_n(ji, jj, ibld(ji, jj))
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            zznd_ml = gdepw_n(ji, jj, jk) / zhbl(ji, jj)
            zdiffut(ji, jj, jk) = 0.75 * zdifml_sc(ji, jj) * zznd_ml * (1.0 - zznd_ml) ** 1.5
            zviscos(ji, jj, jk) = 0.375 * zvisml_sc(ji, jj) * zznd_ml * (1.0 - zznd_ml) * (1.0 - zznd_ml ** 2)
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    WHERE (lconv)
      zsc_wth_1 = zwstrl ** 3 * zwth0 / (zvstr ** 3 + 0.5 * zwstrc ** 3 + epsln)
      zsc_ws_1 = zwstrl ** 3 * zws0 / (zvstr ** 3 + 0.5 * zwstrc ** 3 + epsln)
    ELSEWHERE
      zsc_wth_1 = 2.0 * zwthav
      zsc_ws_1 = 2.0 * zwsav
    END WHERE
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, imld(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + 1.35 * EXP(- zznd_d) * (1.0 - EXP(- 2.0 * zznd_d)) * zsc_wth_1(ji, jj)
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + 1.35 * EXP(- zznd_d) * (1.0 - EXP(- 2.0 * zznd_d)) * zsc_ws_1(ji, jj)
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + 1.5 * EXP(- 0.9 * zznd_d) * (1.0 - EXP(- 4.0 * zznd_d)) * zsc_wth_1(ji, jj)
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + 1.5 * EXP(- 0.9 * zznd_d) * (1.0 - EXP(- 4.0 * zznd_d)) * zsc_ws_1(ji, jj)
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    WHERE (lconv)
      zsc_uw_1 = (zwstrl ** 3 + 0.5 * zwstrc ** 3) ** pthird * zustke / (1.0 - 1.0 * 6.5 * zla ** (8.0 / 3.0))
      zsc_uw_2 = (zwstrl ** 3 + 0.5 * zwstrc ** 3) ** pthird * zustke / (zla ** (8.0 / 3.0) + epsln)
      zsc_vw_1 = ff_t * zhml * zustke ** 3 * zla ** (8.0 / 3.0) / ((zvstr ** 3 + 0.5 * zwstrc ** 3) ** (2.0 / 3.0) + epsln)
    ELSEWHERE
      zsc_uw_1 = zustar ** 2
      zsc_vw_1 = ff_t * zhbl * zustke ** 3 * zla ** (8.0 / 3.0) / (zvstr ** 2 + epsln)
    END WHERE
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, imld(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + (- 0.05 * EXP(- 0.4 * zznd_d) * zsc_uw_1(ji, jj) + 0.00125 * EXP(- zznd_d) * zsc_uw_2(ji, jj)) * (1.0 - EXP(- 2.0 * zznd_d))
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) - 0.65 * 0.15 * EXP(- zznd_d) * (1.0 - EXP(- 2.0 * zznd_d)) * zsc_vw_1(ji, jj)
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            ghamu(ji, jj, jk) = ghamu(ji, jj, jk) - 0.75 * 1.3 * EXP(- 0.5 * zznd_d) * (1.0 - EXP(- 4.0 * zznd_d)) * zsc_uw_1(ji, jj)
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + 0._wp
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    WHERE (lconv)
      zsc_wth_1 = zwbav * zwth0 * (1.0 + EXP(0.2 * zhol)) / (zvstr ** 3 + 0.5 * zwstrc ** 3 + epsln)
      zsc_ws_1 = zwbav * zws0 * (1.0 + EXP(0.2 * zhol)) / (zvstr ** 3 + 0.5 * zwstrc ** 3 + epsln)
    ELSEWHERE
      zsc_wth_1 = 0._wp
      zsc_ws_1 = 0._wp
    END WHERE
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, imld(ji, jj)
            zznd_ml = gdepw_n(ji, jj, jk) / zhml(ji, jj)
            zl_c = 0.9 * (1.0 - EXP(- 7.0 * (zznd_ml - zznd_ml ** 3 / 3.0))) * (1.0 - EXP(- 15.0 * (1.1 - zznd_ml)))
            zl_l = 2.0 * (1.0 - EXP(- 2.0 * (zznd_ml - zznd_ml ** 3 / 3.0))) * (1.0 - EXP(- 5.0 * (1.0 - zznd_ml))) * (1.0 + dstokes(ji, jj) / zhml(ji, jj))
            zl_eps = zl_l + (zl_c - zl_l) / (1.0 + EXP(3.0 * LOG10(- zhol(ji, jj)))) ** (3.0 / 2.0)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + 0.3 * 0.5 * zsc_wth_1(ji, jj) * zl_eps * zhml(ji, jj) / (0.15 + zznd_ml)
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + 0.3 * 0.5 * zsc_ws_1(ji, jj) * zl_eps * zhml(ji, jj) / (0.15 + zznd_ml)
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + zsc_wth_1(ji, jj)
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + zsc_ws_1(ji, jj)
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    WHERE (lconv)
      zsc_uw_1 = - zwb0 * zustar ** 2 * zhml / (zvstr ** 3 + 0.5 * zwstrc ** 3 + epsln)
      zsc_uw_2 = zwb0 * zustke * zhml / (zvstr ** 3 + 0.5 * zwstrc ** 3 + epsln) ** (2.0 / 3.0)
      zsc_vw_1 = 0._wp
    ELSEWHERE
      zsc_uw_1 = 0._wp
      zsc_vw_1 = 0._wp
    END WHERE
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, imld(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + 0.3 * 0.5 * (zsc_uw_1(ji, jj) + 0.125 * EXP(- 0.5 * zznd_d) * (1.0 - EXP(- 0.5 * zznd_d)) * zsc_uw_2(ji, jj))
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + zsc_vw_1(ji, jj)
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + zsc_uw_1(ji, jj)
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + zsc_vw_1(ji, jj)
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    WHERE (lconv)
      zsc_wth_1 = zwth0
      zsc_ws_1 = zws0
    ELSEWHERE
      zsc_wth_1 = 2.0 * zwthav
      zsc_ws_1 = zws0
    END WHERE
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, imld(ji, jj)
            zznd_ml = gdepw_n(ji, jj, jk) / zhml(ji, jj)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + 0.3 * zsc_wth_1(ji, jj) * (- 2.0 + 2.75 * ((1.0 + 0.6 * zznd_ml ** 4) - EXP(- 6.0 * zznd_ml))) * (1.0 - EXP(- 15.0 * (1.0 - zznd_ml)))
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + 0.3 * zsc_ws_1(ji, jj) * (- 2.0 + 2.75 * ((1.0 + 0.6 * zznd_ml ** 4) - EXP(- 6.0 * zznd_ml))) * (1.0 - EXP(- 15.0 * (1.0 - zznd_ml)))
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            znd = gdepw_n(ji, jj, jk) / zhbl(ji, jj)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + 0.3 * (- 4.06 * EXP(- 2.0 * zznd_d) * (1.0 - EXP(- 4.0 * zznd_d)) + 7.5 * EXP(- 10.0 * (0.95 - znd) ** 2) * (1.0 - znd)) * zsc_wth_1(ji, jj)
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + 0.3 * (- 4.06 * EXP(- 2.0 * zznd_d) * (1.0 - EXP(- 4.0 * zznd_d)) + 7.5 * EXP(- 10.0 * (0.95 - znd) ** 2) * (1.0 - znd)) * zsc_ws_1(ji, jj)
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    WHERE (lconv)
      zsc_uw_1 = zustar ** 2
      zsc_vw_1 = ff_t * zustke * zhml
    ELSEWHERE
      zsc_uw_1 = zustar ** 2
      zsc_uw_2 = (2.25 - 3.0 * (1.0 - EXP(- 1.25 * 2.0))) * (1.0 - EXP(- 4.0 * 2.0)) * zsc_uw_1
      zsc_vw_1 = ff_t * zustke * zhbl
      zsc_vw_2 = - 0.11 * SIN(3.14159 * (2.0 + 0.4)) * EXP(- (1.5 + 2.0) ** 2) * zsc_vw_1
    END WHERE
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, imld(ji, jj)
            zznd_ml = gdepw_n(ji, jj, jk) / zhml(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + 0.3 * (- 2.0 + 2.5 * (1.0 + 0.1 * zznd_ml ** 4) - EXP(- 8.0 * zznd_ml)) * zsc_uw_1(ji, jj)
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + 0.3 * 0.1 * (EXP(- zznd_d) + EXP(- 5.0 * (1.0 - zznd_ml))) * zsc_vw_1(ji, jj)
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            znd = gdepw_n(ji, jj, jk) / zhbl(ji, jj)
            zznd_d = gdepw_n(ji, jj, jk) / dstokes(ji, jj)
            IF (zznd_d <= 2.0) THEN
              ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + 0.5 * 0.3 * (2.25 - 3.0 * (1.0 - EXP(- 1.25 * zznd_d)) * (1.0 - EXP(- 2.0 * zznd_d))) * zsc_uw_1(ji, jj)
            ELSE
              ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + 0.5 * 0.3 * (1.0 - EXP(- 5.0 * (1.0 - znd))) * zsc_uw_2(ji, jj)
            END IF
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + 0.3 * 0.15 * SIN(3.14159 * (0.65 * zznd_d)) * EXP(- 0.25 * zznd_d ** 2) * zsc_vw_1(ji, jj)
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + 0.3 * 0.15 * EXP(- 5.0 * (1.0 - znd)) * (1.0 - EXP(- 20.0 * (1.0 - znd))) * zsc_vw_2(ji, jj)
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            znd = (gdepw_n(ji, jj, jk) - zhml(ji, jj)) / zhml(ji, jj)
            IF (znd >= 0.0) THEN
              ghamu(ji, jj, jk) = ghamu(ji, jj, jk) * (1.0 - EXP(- 30.0 * znd ** 2))
              ghamv(ji, jj, jk) = ghamv(ji, jj, jk) * (1.0 - EXP(- 30.0 * znd ** 2))
            ELSE
              ghamu(ji, jj, jk) = 0._wp
              ghamv(ji, jj, jk) = 0._wp
            END IF
          END DO
          !$ACC END KERNELS
        ELSE
          !$ACC KERNELS
          DO jk = 2, ibld(ji, jj)
            znd = (gdepw_n(ji, jj, jk) - zhml(ji, jj)) / zhml(ji, jj)
            IF (znd >= 0.0) THEN
              ghamu(ji, jj, jk) = ghamu(ji, jj, jk) * (1.0 - EXP(- 10.0 * znd ** 2))
              ghamv(ji, jj, jk) = ghamv(ji, jj, jk) * (1.0 - EXP(- 10.0 * znd ** 2))
            ELSE
              ghamu(ji, jj, jk) = 0._wp
              ghamv(ji, jj, jk) = 0._wp
            END IF
          END DO
          !$ACC END KERNELS
        END IF
      END DO
    END DO
    !$ACC KERNELS
    zsc_uw_1 = 0._wp
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        DO jk = 2, ibld(ji, jj)
          znd = gdepw_n(ji, jj, jk) / zhbl(ji, jj)
          ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + zdiffut(ji, jj, jk) * zdtdz_pyc(ji, jj, jk)
          ghams(ji, jj, jk) = ghams(ji, jj, jk) + zdiffut(ji, jj, jk) * zdsdz_pyc(ji, jj, jk)
          ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + zviscos(ji, jj, jk) * zdudz_pyc(ji, jj, jk)
          ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + zsc_uw_1(ji, jj) * (1.0 - znd) ** (7.0 / 4.0) * zdbdz_pyc(ji, jj, jk)
          ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + zviscos(ji, jj, jk) * zdvdz_pyc(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        IF (lconv(ji, jj)) THEN
          !$ACC KERNELS
          DO jk = 1, imld(ji, jj) - 1
            znd = gdepw_n(ji, jj, jk) / zhml(ji, jj)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + zwth_ent(ji, jj) * znd
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + zws_ent(ji, jj) * znd
            ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + zuw_bse(ji, jj) * znd
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + zvw_bse(ji, jj) * znd
          END DO
          DO jk = imld(ji, jj), ibld(ji, jj)
            znd = - (gdepw_n(ji, jj, jk) - zhml(ji, jj)) / zdh(ji, jj)
            ghamt(ji, jj, jk) = ghamt(ji, jj, jk) + zwth_ent(ji, jj) * (1.0 + znd)
            ghams(ji, jj, jk) = ghams(ji, jj, jk) + zws_ent(ji, jj) * (1.0 + znd)
            ghamu(ji, jj, jk) = ghamu(ji, jj, jk) + zuw_bse(ji, jj) * (1.0 + znd)
            ghamv(ji, jj, jk) = ghamv(ji, jj, jk) + zvw_bse(ji, jj) * (1.0 + znd)
          END DO
          !$ACC END KERNELS
        END IF
        ghamt(ji, jj, ibld(ji, jj)) = 0._wp
        ghams(ji, jj, ibld(ji, jj)) = 0._wp
        ghamu(ji, jj, ibld(ji, jj)) = 0._wp
        ghamv(ji, jj, ibld(ji, jj)) = 0._wp
      END DO
    END DO
    !$ACC KERNELS
    DO jj = 2, jpjm1
      DO ji = 2, jpim1
        DO jk = 2, ibld(ji, jj)
          ztemp = ghamu(ji, jj, jk)
          ghamu(ji, jj, jk) = ghamu(ji, jj, jk) * zcos_wind(ji, jj) - ghamv(ji, jj, jk) * zsin_wind(ji, jj)
          ghamv(ji, jj, jk) = ghamv(ji, jj, jk) * zcos_wind(ji, jj) + ztemp * zsin_wind(ji, jj)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (ln_dia_osm) THEN
      IF (iom_use("zdtdz_pyc")) CALL iom_put("zdtdz_pyc", wmask * zdtdz_pyc)
    END IF
    IF (ln_kpprimix) THEN
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 1, jpjm1
          DO ji = 1, jpim1
            z3du(ji, jj, jk) = 0.5 * (un(ji, jj, jk - 1) - un(ji, jj, jk)) * (ub(ji, jj, jk - 1) - ub(ji, jj, jk)) * wumask(ji, jj, jk) / (e3uw_n(ji, jj, jk) * e3uw_b(ji, jj, jk))
            z3dv(ji, jj, jk) = 0.5 * (vn(ji, jj, jk - 1) - vn(ji, jj, jk)) * (vb(ji, jj, jk - 1) - vb(ji, jj, jk)) * wvmask(ji, jj, jk) / (e3vw_n(ji, jj, jk) * e3vw_b(ji, jj, jk))
          END DO
        END DO
      END DO
      DO jk = 2, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            zesh2 = (z3du(ji - 1, jj, jk) + z3du(ji, jj, jk)) / MAX(1._wp, umask(ji - 1, jj, jk) + umask(ji, jj, jk)) + (z3dv(ji, jj - 1, jk) + z3dv(ji, jj, jk)) / MAX(1._wp, vmask(ji, jj - 1, jk) + vmask(ji, jj, jk))
            zri = MAX(rn2b(ji, jj, jk), 0._wp) / MAX(zesh2, epsln)
            zfri = MIN(zri / rn_riinfty, 1.0_wp)
            zfri = (1.0_wp - zfri * zfri)
            zrimix(ji, jj, jk) = zfri * zfri * zfri * wmask(ji, jj, jk)
          END DO
        END DO
      END DO
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          DO jk = ibld(ji, jj) + 1, jpkm1
            zdiffut(ji, jj, jk) = zrimix(ji, jj, jk) * rn_difri
            zviscos(ji, jj, jk) = zrimix(ji, jj, jk) * rn_difri
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    IF (ln_convmix) THEN
      !$ACC KERNELS
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          DO jk = ibld(ji, jj) + 1, jpkm1
            IF (MIN(rn2(ji, jj, jk), rn2b(ji, jj, jk)) <= - 1.E-12) zdiffut(ji, jj, jk) = rn_difconv
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    END IF
    CALL lbc_lnk(zviscos(:, :, :), 'W', 1.)
    !$ACC KERNELS
    DO jk = 2, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          p_avt(ji, jj, jk) = MAX(zdiffut(ji, jj, jk), avtb(jk)) * tmask(ji, jj, jk)
          p_avm(ji, jj, jk) = MAX(zviscos(ji, jj, jk), avmb(jk)) * tmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk_multi(p_avt, 'W', 1., p_avm, 'W', 1., ghamu, 'W', 1., ghamv, 'W', 1.)
    !$ACC KERNELS
    DO jk = 2, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          ghamu(ji, jj, jk) = (ghamu(ji, jj, jk) + ghamu(ji + 1, jj, jk)) / MAX(1., tmask(ji, jj, jk) + tmask(ji + 1, jj, jk)) * umask(ji, jj, jk)
          ghamv(ji, jj, jk) = (ghamv(ji, jj, jk) + ghamv(ji, jj + 1, jk)) / MAX(1., tmask(ji, jj, jk) + tmask(ji, jj + 1, jk)) * vmask(ji, jj, jk)
          ghamt(ji, jj, jk) = ghamt(ji, jj, jk) * tmask(ji, jj, jk)
          ghams(ji, jj, jk) = ghams(ji, jj, jk) * tmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    CALL lbc_lnk_multi(ghamt, 'W', 1., ghams, 'W', 1., ghamu, 'U', 1., ghamv, 'V', 1.)
    IF (ln_dia_osm) THEN
      SELECT CASE (nn_osm_wave)
      CASE (0 : 1)
        IF (iom_use("us_x")) CALL iom_put("us_x", tmask(:, :, 1) * zustke * zcos_wind)
        IF (iom_use("us_y")) CALL iom_put("us_y", tmask(:, :, 1) * zustke * zsin_wind)
        IF (iom_use("wind_wave_abs_power")) CALL iom_put("wind_wave_abs_power", 1000. * rau0 * tmask(:, :, 1) * zustar ** 2 * zustke)
      CASE (2)
        IF (iom_use("us_x")) CALL iom_put("us_x", ut0sd)
        IF (iom_use("us_y")) CALL iom_put("us_y", vt0sd)
        IF (iom_use("wind_wave_abs_power")) CALL iom_put("wind_wave_abs_power", 1000. * rau0 * tmask(:, :, 1) * zustar ** 2 * SQRT(ut0sd ** 2 + vt0sd ** 2))
      END SELECT
      IF (iom_use("ghamt")) CALL iom_put("ghamt", tmask * ghamt)
      IF (iom_use("ghams")) CALL iom_put("ghams", tmask * ghams)
      IF (iom_use("ghamu")) CALL iom_put("ghamu", umask * ghamu)
      IF (iom_use("ghamv")) CALL iom_put("ghamv", vmask * ghamv)
      IF (iom_use("zwth0")) CALL iom_put("zwth0", tmask(:, :, 1) * zwth0)
      IF (iom_use("zws0")) CALL iom_put("zws0", tmask(:, :, 1) * zws0)
      IF (iom_use("hbl")) CALL iom_put("hbl", tmask(:, :, 1) * hbl)
      IF (iom_use("hbli")) CALL iom_put("hbli", tmask(:, :, 1) * hbli)
      IF (iom_use("dstokes")) CALL iom_put("dstokes", tmask(:, :, 1) * dstokes)
      IF (iom_use("zustke")) CALL iom_put("zustke", tmask(:, :, 1) * zustke)
      IF (iom_use("zwstrc")) CALL iom_put("zwstrc", tmask(:, :, 1) * zwstrc)
      IF (iom_use("zwstrl")) CALL iom_put("zwstrl", tmask(:, :, 1) * zwstrl)
      IF (iom_use("zustar")) CALL iom_put("zustar", tmask(:, :, 1) * zustar)
      IF (iom_use("wind_power")) CALL iom_put("wind_power", 1000. * rau0 * tmask(:, :, 1) * zustar ** 3)
      IF (iom_use("wind_wave_power")) CALL iom_put("wind_wave_power", 1000. * rau0 * tmask(:, :, 1) * zustar ** 2 * zustke)
      IF (iom_use("zhbl")) CALL iom_put("zhbl", tmask(:, :, 1) * zhbl)
      IF (iom_use("zhml")) CALL iom_put("zhml", tmask(:, :, 1) * zhml)
      IF (iom_use("zdh")) CALL iom_put("zdh", tmask(:, :, 1) * zdh)
      IF (iom_use("zhol")) CALL iom_put("zhol", tmask(:, :, 1) * zhol)
      IF (iom_use("zwthav")) CALL iom_put("zwthav", tmask(:, :, 1) * zwthav)
      IF (iom_use("zwth_ent")) CALL iom_put("zwth_ent", tmask(:, :, 1) * zwth_ent)
      IF (iom_use("zt_ml")) CALL iom_put("zt_ml", tmask(:, :, 1) * zt_ml)
    END IF
    CALL lbc_lnk(p_avt(:, :, :), 'W', 1.)
  END SUBROUTINE zdf_osm
  SUBROUTINE zdf_osm_init
    INTEGER :: ios
    INTEGER :: ji, jj, jk
    NAMELIST /namzdf_osm/ ln_use_osm_la, rn_osm_la, rn_osm_dstokes, nn_ave, nn_osm_wave, ln_dia_osm, rn_osm_hbl0, ln_kpprimix, rn_riinfty, rn_difri, ln_convmix, rn_difconv
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namzdf_osm, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namzdf_osm in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namzdf_osm, IOSTAT = ios, ERR = 902)
902 IF (ios > 0) CALL ctl_nam(ios, 'namzdf_osm in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namzdf_osm)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'zdf_osm_init : OSMOSIS Parameterisation'
      WRITE(numout, FMT = *) '~~~~~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namzdf_osm : set tke mixing parameters'
      WRITE(numout, FMT = *) '     Use namelist  rn_osm_la                     ln_use_osm_la = ', ln_use_osm_la
      WRITE(numout, FMT = *) '     Turbulent Langmuir number                     rn_osm_la   = ', rn_osm_la
      WRITE(numout, FMT = *) '     Initial hbl for 1D runs                       rn_osm_hbl0   = ', rn_osm_hbl0
      WRITE(numout, FMT = *) '     Depth scale of Stokes drift                rn_osm_dstokes = ', rn_osm_dstokes
      WRITE(numout, FMT = *) '     horizontal average flag                       nn_ave      = ', nn_ave
      WRITE(numout, FMT = *) '     Stokes drift                                  nn_osm_wave = ', nn_osm_wave
      SELECT CASE (nn_osm_wave)
      CASE (0)
        WRITE(numout, FMT = *) '     calculated assuming constant La#=0.3'
      CASE (1)
        WRITE(numout, FMT = *) '     calculated from Pierson Moskowitz wind-waves'
      CASE (2)
        WRITE(numout, FMT = *) '     calculated from ECMWF wave fields'
      END SELECT
      WRITE(numout, FMT = *) '     Output osm diagnostics                       ln_dia_osm  = ', ln_dia_osm
      WRITE(numout, FMT = *) '     Use KPP-style shear instability mixing       ln_kpprimix = ', ln_kpprimix
      WRITE(numout, FMT = *) '     local Richardson Number limit for shear instability rn_riinfty = ', rn_riinfty
      WRITE(numout, FMT = *) '     maximum shear diffusivity at Rig = 0    (m2/s) rn_difri = ', rn_difri
      WRITE(numout, FMT = *) '     Use large mixing below BL when unstable       ln_convmix = ', ln_convmix
      WRITE(numout, FMT = *) '     diffusivity when unstable below BL     (m2/s) rn_difconv = ', rn_difconv
    END IF
    IF (zdf_osm_alloc() /= 0) CALL ctl_stop('STOP', 'zdf_osm_init : unable to allocate arrays')
    CALL osm_rst(nit000, 'READ')
    IF (ln_zdfddm) THEN
      IF (lwp) THEN
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '    Double diffusion mixing on temperature and salinity '
        WRITE(numout, FMT = *) '    CAUTION : done in routine zdfosm, not in routine zdfddm '
      END IF
    END IF
    IF (lwp) THEN
      WRITE(numout, FMT = *)
    END IF
    IF (nn_osm_wave == 0) THEN
      !$ACC KERNELS
      dstokes(:, :) = rn_osm_dstokes
      !$ACC END KERNELS
    END IF
    SELECT CASE (nn_ave)
    CASE (0)
      IF (lwp) WRITE(numout, FMT = *) '          no horizontal average on avt'
      IF (lwp) WRITE(numout, FMT = *) '          only in very high horizontal resolution !'
      !$ACC KERNELS
      etmean(:, :, :) = 0.E0
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            etmean(ji, jj, jk) = tmask(ji, jj, jk) / MAX(1., umask(ji - 1, jj, jk) + umask(ji, jj, jk) + vmask(ji, jj - 1, jk) + vmask(ji, jj, jk))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE (1)
      IF (lwp) WRITE(numout, FMT = *) '          horizontal average on avt'
      !$ACC KERNELS
      etmean(:, :, :) = 0.E0
      DO jk = 1, jpkm1
        DO jj = 2, jpjm1
          DO ji = 2, jpim1
            etmean(ji, jj, jk) = tmask(ji, jj, jk) / MAX(1., 2. * tmask(ji, jj, jk) + .5 * (tmask(ji - 1, jj + 1, jk) + tmask(ji - 1, jj - 1, jk) + tmask(ji + 1, jj + 1, jk) + tmask(ji + 1, jj - 1, jk)) + 1. * (tmask(ji - 1, jj, jk) + tmask(ji, jj + 1, jk) + tmask(ji, jj - 1, jk) + tmask(ji + 1, jj, jk)))
          END DO
        END DO
      END DO
      !$ACC END KERNELS
    CASE DEFAULT
      WRITE(ctmp1, FMT = *) '          bad flag value for nn_ave = ', nn_ave
      CALL ctl_stop(ctmp1)
    END SELECT
    !$ACC KERNELS
    DO jk = 1, jpk
      avt(:, :, jk) = avtb(jk) * tmask(:, :, jk)
    END DO
    ghamt(:, :, :) = 0.
    ghams(:, :, :) = 0.
    ghamu(:, :, :) = 0.
    ghamv(:, :, :) = 0.
    !$ACC END KERNELS
    IF (lwxios) THEN
      CALL iom_set_rstw_var_active('wn')
      CALL iom_set_rstw_var_active('hbl')
      CALL iom_set_rstw_var_active('hbli')
    END IF
  END SUBROUTINE zdf_osm_init
  SUBROUTINE osm_rst(kt, cdrw)
    INTEGER, INTENT(IN) :: kt
    CHARACTER(LEN = *), INTENT(IN) :: cdrw
    INTEGER :: id1, id2
    INTEGER :: ji, jj, jk
    INTEGER :: iiki, ikt
    REAL(KIND = wp) :: zhbf
    REAL(KIND = wp) :: zN2_c
    REAL(KIND = wp) :: rho_c = 0.01_wp
    INTEGER, DIMENSION(:, :), ALLOCATABLE :: imld_rst
    IF (TRIM(cdrw) == 'READ' .AND. ln_rstart) THEN
      id1 = iom_varid(numror, 'wn', ldstop = .FALSE.)
      IF (id1 > 0) THEN
        CALL iom_get(numror, jpdom_autoglo, 'wn', wn, ldxios = lrxios)
        WRITE(numout, FMT = *) ' ===>>>> :  wn read from restart file'
      ELSE
        !$ACC KERNELS
        wn(:, :, :) = 0._wp
        !$ACC END KERNELS
        WRITE(numout, FMT = *) ' ===>>>> :  wn not in restart file, set to zero initially'
      END IF
      id1 = iom_varid(numror, 'hbl', ldstop = .FALSE.)
      id2 = iom_varid(numror, 'hbli', ldstop = .FALSE.)
      IF (id1 > 0 .AND. id2 > 0) THEN
        CALL iom_get(numror, jpdom_autoglo, 'hbl', hbl, ldxios = lrxios)
        CALL iom_get(numror, jpdom_autoglo, 'hbli', hbli, ldxios = lrxios)
        WRITE(numout, FMT = *) ' ===>>>> :  hbl & hbli read from restart file'
        RETURN
      ELSE
        WRITE(numout, FMT = *) ' ===>>>> : previous run without osmosis scheme, hbl computed from stratification'
      END IF
    END IF
    IF (TRIM(cdrw) == 'WRITE') THEN
      IF (lwp) WRITE(numout, FMT = *) '---- osm-rst ----'
      CALL iom_rstput(kt, nitrst, numrow, 'wn', wn, ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'hbl', hbl, ldxios = lwxios)
      CALL iom_rstput(kt, nitrst, numrow, 'hbli', hbli, ldxios = lwxios)
      RETURN
    END IF
    IF (lwp) WRITE(numout, FMT = *) ' ===>>>> : calculating hbl computed from stratification'
    ALLOCATE(imld_rst(jpi, jpj))
    CALL eos_rab(tsn, rab_n)
    CALL bn2(tsn, rab_n, rn2)
    !$ACC KERNELS
    imld_rst(:, :) = nlb10
    hbl(:, :) = 0._wp
    zN2_c = grav * rho_c * r1_rau0
    hbl(:, :) = 0._wp
    DO jk = 1, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          ikt = mbkt(ji, jj)
          hbl(ji, jj) = hbl(ji, jj) + MAX(rn2(ji, jj, jk), 0._wp) * e3w_n(ji, jj, jk)
          IF (hbl(ji, jj) < zN2_c) imld_rst(ji, jj) = MIN(jk, ikt) + 1
        END DO
      END DO
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        iiki = imld_rst(ji, jj)
        hbl(ji, jj) = gdepw_n(ji, jj, iiki) * ssmask(ji, jj)
      END DO
    END DO
    hbl = MAX(hbl, epsln)
    hbli(:, :) = hbl(:, :)
    !$ACC END KERNELS
    DEALLOCATE(imld_rst)
    WRITE(numout, FMT = *) ' ===>>>> : hbl computed from stratification'
  END SUBROUTINE osm_rst
  SUBROUTINE tra_osm(kt)
    REAL(KIND = wp), DIMENSION(:, :, :), ALLOCATABLE :: ztrdt, ztrds
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk
    IF (kt == nit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'tra_osm : OSM non-local tracer fluxes'
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~   '
    END IF
    IF (l_trdtra) THEN
      ALLOCATE(ztrdt(jpi, jpj, jpk))
      !$ACC KERNELS
      ztrdt(:, :, :) = tsa(:, :, :, jp_tem)
      !$ACC END KERNELS
      ALLOCATE(ztrds(jpi, jpj, jpk))
      !$ACC KERNELS
      ztrds(:, :, :) = tsa(:, :, :, jp_sal)
      !$ACC END KERNELS
    END IF
    !$ACC KERNELS
    DO jk = 1, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          tsa(ji, jj, jk, jp_tem) = tsa(ji, jj, jk, jp_tem) - (ghamt(ji, jj, jk) - ghamt(ji, jj, jk + 1)) / e3t_n(ji, jj, jk)
          tsa(ji, jj, jk, jp_sal) = tsa(ji, jj, jk, jp_sal) - (ghams(ji, jj, jk) - ghams(ji, jj, jk + 1)) / e3t_n(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (l_trdtra) THEN
      !$ACC KERNELS
      ztrdt(:, :, :) = tsa(:, :, :, jp_tem) - ztrdt(:, :, :)
      ztrds(:, :, :) = tsa(:, :, :, jp_sal) - ztrds(:, :, :)
      !$ACC END KERNELS
      CALL trd_tra(kt, 'TRA', jp_tem, jptra_zdf, ztrdt)
      CALL trd_tra(kt, 'TRA', jp_sal, jptra_zdf, ztrds)
      DEALLOCATE(ztrdt)
      DEALLOCATE(ztrds)
    END IF
    IF (ln_ctl) THEN
      CALL prt_ctl(tab3d_1 = tsa(:, :, :, jp_tem), clinfo1 = ' osm  - Ta: ', mask1 = tmask, tab3d_2 = tsa(:, :, :, jp_sal), clinfo2 = ' Sa: ', mask2 = tmask, clinfo3 = 'tra')
    END IF
  END SUBROUTINE tra_osm
  SUBROUTINE trc_osm(kt)
    INTEGER, INTENT(IN) :: kt
    WRITE(*, FMT = *) 'trc_osm: Not written yet', kt
  END SUBROUTINE trc_osm
  SUBROUTINE dyn_osm(kt)
    INTEGER, INTENT(IN) :: kt
    INTEGER :: ji, jj, jk
    IF (kt == nit000) THEN
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) 'dyn_osm : OSM non-local velocity'
      IF (lwp) WRITE(numout, FMT = *) '~~~~~~~   '
    END IF
    !$ACC KERNELS
    DO jk = 1, jpkm1
      DO jj = 2, jpjm1
        DO ji = 2, jpim1
          ua(ji, jj, jk) = ua(ji, jj, jk) - (ghamu(ji, jj, jk) - ghamu(ji, jj, jk + 1)) / e3u_n(ji, jj, jk)
          va(ji, jj, jk) = va(ji, jj, jk) - (ghamv(ji, jj, jk) - ghamv(ji, jj, jk + 1)) / e3v_n(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
  END SUBROUTINE dyn_osm
END MODULE zdfosm