      SUBROUTINE PLT_EXCD
     &          (plt_device,plt_orientation,
     &           brief,xlbl,ylbl,
     &           ntlist,ntl,nplt,
     &           plot_lbl,graf_lbl,
     &           xmtr_lbl,data_lbl,
     &           prfl_lbl,file_lbl,
     &           rcvr_lbl,cntr_lbl,
     &           tlevel,ntlvl,
     &           plevel,nplvl,
     &           cntr_lvl,mxcntr,
     &           opa_lat,opa_lon,
     &           grd_lat,grd_lon,
     &           map_type,map_size,map_tics,map_grid,
     &           terminator,chi_list,
     &           chi_max,chi_min,chi_inc,
     &           chi_label,chi_line,
     &           amp1,std1,ampl,mxlat,nrlat,mxlon,nrlon)

c Sets up contours of % availibility for fixed signal levels

c Change History

c     26 Sep 1994   Made compatible with new contour routines; only does
c                   fill contours now; removed display of %Sea %Map on
c                   plot.

c     03 Oct 1994   Moved world map call from PLT_CNTR_LABEL so that it
c                   overlays the filled contours.

c     16 Apr 1995   Changed to use new geophysics routines and to use
c                   colors from the GRAPHICS.INI file.

c     22 May 1995   Added solid fills for LJC color device.

c     07 Jun 1995   Moved generation of plot labels and maps to the
c                   calling routine.

c     26 Aug 1995   Changed PLT_CNTR, PLT_EXCD and PLT_JOINT_CNTR to use
c                   fills from GRAPHICS.INI; the variable USE_FILL_LIST
c                   is removed.

c     01 Feb 1996   Changed to only use contour levels from an input
c                   array; calculate the contour data array in the
c                   calling routine.

c     06 Feb 1996   Changed graph label, i.e., S/N, to a single element
c                   to allow better alignment of the contour labels.

c     24 Feb 1996   Moved cells,mxcells,nrpts,mxholes,xwork,ywork,mxwork
c                   from argument list to new common block grf$cntr.

c     12 Mar 1997   Modified to use new string routines in GRF.

c     23 Jun 1997   Moved common blocks of code from grdPlot to this
c                   routine to reduce the size of grdPlot.

c     13 Jan 1998   Dropped test for output device re setting the color
c                   and fill accordingly.

c     14 Jan 98     Removed PLT_UNIT.

c     Graphics parameters
      include      'graphics.cmn'

c     Map parameters
      include      'lwpc_geo.cmn'

      character*(*) plt_device,plt_orientation,
     &              plot_lbl,graf_lbl,
     &              xmtr_lbl(-1:6),data_lbl(-1:6),
     &              prfl_lbl(-1:6),file_lbl(-1:6),
     &              rcvr_lbl(-1:1),cntr_lbl(mxcntr),
     &              map_type(2)
      logical       map_grid,terminator,chi_label
      integer       mnth_num,day,year,UT,chi_line
      real          tlevel(7),
     &              plevel(7),
     &              cntr_lvl(mxcntr),
     &              opa_lat(2),opa_lon(2),
     &              grd_lat(2),grd_lon(2),
     &              map_size(2),map_tics(2),
     &              chi_list(2),chi_max,chi_min,chi_inc,
     &              amp1(mxlon,mxlat),
     &              std1(mxlon,mxlat),
     &              ampl(mxlon,mxlat)

      character*  3 mnth_nam
      character*  8 color,fill
      character* 80 plblx
      dimension     xl(2),yl(2),zcntr(2)

      do np=1,ntlvl

c        Initiate graphics
         call GRF_BEGIN (plt_device,plt_orientation)

c        Set up labels for this specific plot
         xlbl=map_size(1)
         ylbl=map_size(2)

         call PLT_CNTR_LABEL
     &       (brief,xlbl,ylbl,
     &        ntlist,ntl,
     &        plot_lbl,graf_lbl,
     &        xmtr_lbl,data_lbl,
     &        prfl_lbl,file_lbl,
     &        rcvr_lbl)

c        Set up time availibility contours
c        parametric in signal, SNR, etc. level
         slvl=tlevel(np)

c        Get number of standard deviations corresponding
c        to specified threshold
         do l=1,nrlat
            do k=1,nrlon
               ampl(k,l)=(amp1(k,l)-slvl)/std1(k,l)
            end do
         end do

         do nl=1,nplvl
            cntr_lvl(nl)=plevel(nl)
         end do
         nrlvl=nplvl
         do nl=1,nrlvl-1

            sigmas=PROB_TO_SIGMA (cntr_lvl(nl+1))

            call PLT_AREA_SIZE
     &          (mxlat,nrlat,mxlon,nrlon,
     &           ampl,opa_lat,opa_lon,
     &           sigmas,area_a,area_o)

            write(cntr_lbl(nl),
     &          '(i3,'' to '',i3,7x,i3)')
     &            INT(cntr_lvl(nl)),INT(cntr_lvl(nl+1)),
     &            INT(area_o)
         end do

c        Label for the threshold
         call GRF_STRING (xlbl,ylbl,.1,graf_lbl,0.,'LB',retX)
         ylbl=ylbl-.15

         write(plblx,'(''Threshold:'',f5.1)'')') slvl

         call GRF_STRING (xlbl,ylbl,.1,plblx,0.,'LB',adjX)
         ylbl=ylbl-.15

c        Double space
         ylbl=ylbl-.15

c        Label for the contours
         plblx='% availability'

c        Add %ocean tag to label
         write(plblx(19:),'(''%O'')')

         call GRF_STRING (xlbl,ylbl,.1,plblx,0.,'LB',retX)
         adjX=MAX(adjX,retX)
         ylbl=ylbl-.15

c        Define a format to be used for numerical labels of the contours
         xl(1)=xlbl+adjX
         xl(2)=xlbl+adjX+.6

c        Do contour plots
         do nc=1,nrlvl-1

            kk=MOD(nc,8)
            if (kk .eq. 0) kk=8

            write(color,'(''color'',i1)') kk
            fill='solid'

c           Set up number of sigmas corresponding to each probability level
            zcntr(1)=PROB_TO_SIGMA (cntr_lvl(nc  ))
            zcntr(2)=PROB_TO_SIGMA (cntr_lvl(nc+1))

c           Label for this contour
            call GRF_COLOR ('labels')
            call GRF_STRING (xlbl,ylbl,.1,cntr_lbl(nc),0.,'LB',retX)

            yl(1)=ylbl
            yl(2)=ylbl+0.1

            call GRF_COLOR (color)
            call GRF_FILL_RECT (xl(1),yl(1),xl(2),yl(2),fill)

            ylbl=ylbl-.15

            call GEO_CNTR
     &          (ampl,mxlon,mxlat,nrlon,nrlat,
     &           grd_lat,grd_lon,
     &           zcntr,0,fill,color)
         end do

c        Generate map
         call WORLD_MAP
     &       (map_type,map_grid,map_tics)

         if (terminator) then

c           Show the terminator boundaries on the map
c           ONLY IF the signal data was run for a specific
c           date and time
            if (prfl_lbl(nplt)(:10) .eq. 'LWPM Date:') then

c              Extract the date and time
               read (prfl_lbl(nplt),'(11x,3(i2,1x),i4)')
     &               mnth_num,day,year,UT
               call MONTH_NAME (mnth_num,mnth_nam)
               UThrs=(UT-40.*INT(UT/100.))/60.
               call GEO_CHI_MAP
     &             (mnth_nam,day,year,UThrs,
     &              2,2,chi_list,
     &              chi_max,chi_min,chi_inc,
     &              chi_label,chi_line)
            end if
         end if
         call GRF_DONE
      end do
      RETURN
      END      ! PLT_EXCD


Block Data zpcbdt
   Implicit Double Precision (A-H, O-Z)
   Parameter (maxptn=400001)
   Parameter (maxstr=150001)
   Common /para1/mul
   Common /para2/xmp, xmu, alpha, rscut2, cutof2
   Common /para3/nsevt, nevnt, nsbrun, ievt, isbrun
   Common /para4/iftflg, ireflg, igeflg, ibstfg
   Common /para5/iconfg, iordsc
   Common /para6/centy
   Common /para7/ioscar, nsmbbbar, nsmmeson
   Common /prec1/gx0(maxptn), gy0(maxptn), gz0(maxptn), ft0(maxptn), px0(maxptn), py0(maxptn), pz0(maxptn), e0(maxptn), xmass0(maxptn), ityp0(maxptn)
   Common /prec2/gx(maxptn), gy(maxptn), gz(maxptn), ft(maxptn), px(maxptn), py(maxptn), pz(maxptn), e(maxptn), xmass(maxptn), ityp(maxptn)
   Common /prec3/gxs(maxptn), gys(maxptn), gzs(maxptn), fts(maxptn), pxs(maxptn), pys(maxptn), pzs(maxptn), es(maxptn), xmasss(maxptn), ityps(maxptn)
   Common /prec4/vx(maxptn), vy(maxptn), vz(maxptn)
   Common /prec5/eta(maxptn), rap(maxptn), tau(maxptn)
   Common /prec6/etas(maxptn), raps(maxptn), taus(maxptn)
   Common /aurec1/jxa, jya, jza
   Common /aurec2/dgxa(maxptn), dgya(maxptn), dgza(maxptn)
   Common /ilist1/iscat, jscat, next(maxptn), last(maxptn), ictype, icsta(maxptn), nic(maxptn), icels(maxptn)
   Common /ilist2/icell, icel(10, 10, 10)
   Common /ilist3/size1, size2, size3, v1, v2, v3, size
   Common /ilist4/ifmpt, ichkpt, indx(maxptn)
   Common /ilist6/t, iopern, icolln
   Common /ilist7/lstrg0(maxptn), lpart0(maxptn)
   Common /ilist8/lstrg1(maxptn), lpart1(maxptn)
   Common /rndm1/number
   Common /rndm2/iff
   Common /rndm3/iseedp
   Common /ana1/ts(12)
   Common /ana2/det(12), dn(12), detdy(12), detdn(12), dndy(12), det1(12), dn1(12), detdy1(12), detdn1(12), dndy1(12), det2(12), dn2(12), detdy2(12), detdn2(12), dndy2(12)
   Common /ana3/em(4, 4, 12)
   Common /ana4/fdetdy(24), fdndy(24), fdndpt(12)
   Save
   Data centy/0D0/
   Data number/0/
   Data ts/0.11D0, 0.12D0, 0.15D0, 0.2D0, 0.3D0, 0.4D0, 0.6D0, 0.8D0, 1D0, 2D0, 4D0, 6D0/
End Block Data


MODULE ps_nloc2_variables

  use parallel_module, only: MPI_REAL8,MPI_COMPLEX16,nprocs_g

  integer :: Mlma,nzlma
  integer,allocatable :: JJ_MAP(:,:,:),MJJ_MAP(:),MJJ(:)
  integer :: MMJJ,MAXMJJ,nrlma_xyz(6)
  real(8),allocatable :: uV(:,:)
  integer,allocatable :: amap(:),lmap(:),mmap(:),iorbmap(:)
  integer,allocatable :: lma_nsend(:),iuV(:),nl_rank_map(:)
  integer,allocatable :: num_2_rank(:,:)
  integer,allocatable :: sendmap(:,:),recvmap(:,:)
  integer,allocatable :: JJP(:,:)
  integer :: nl_max_send
#ifdef _DRSDFT_
  real(8),allocatable :: uVk(:,:,:),sbufnl(:,:),rbufnl(:,:)
  real(8),allocatable :: xVk(:,:,:),yVk(:,:,:),zVk(:,:,:)
  real(8),allocatable :: uVunk(:,:),uVunk0(:,:)
  real(8),parameter :: zero=0.d0
  integer,parameter :: TYPE_MAIN=MPI_REAL8
#else
  complex(8),allocatable :: uVk(:,:,:),sbufnl(:,:),rbufnl(:,:)
  complex(8),allocatable :: xVk(:,:,:),yVk(:,:,:),zVk(:,:,:)
  complex(8),allocatable :: uVunk(:,:),uVunk0(:,:)
  complex(8),parameter :: zero=(0.d0,0.d0)
  integer,parameter :: TYPE_MAIN=MPI_COMPLEX16
#endif

CONTAINS

  SUBROUTINE allocate_ps_nloc2(MB_d)
    integer,intent(IN) :: MB_d
    integer :: n
    n=maxval( lma_nsend )*4*MB_d
    if ( allocated(rbufnl) ) deallocate(rbufnl)
    if ( allocated(sbufnl) ) deallocate(sbufnl)
    if ( allocated(uVunk)  ) deallocate(uVunk)
    if ( allocated(uVunk0) ) deallocate(uVunk0)
    allocate( sbufnl(n,0:nprocs_g-1) ) ; sbufnl=zero
    allocate( rbufnl(n,0:nprocs_g-1) ) ; rbufnl=zero
    allocate( uVunk(nzlma,MB_d)  ) ; uVunk=zero
    allocate( uVunk0(nzlma,MB_d) ) ; uVunk0=zero
  END SUBROUTINE allocate_ps_nloc2

  SUBROUTINE checkMapsBeforeForce(myrank)
    implicit none
    integer,intent(IN) :: myrank
    integer :: i
    write(5000+myrank,'(2A7)') 'nzlma','amap'
    write(5100+myrank,'(2A7)') 'nzlma','lmap'
    write(5200+myrank,'(2A7)') 'nzlma','mmap'
    write(5300+myrank,'(2A7)') 'nzlma','iorbmap'
    do i=1,nzlma
      write(5000+myrank,'(2I7)') nzlma,amap(i)
      write(5100+myrank,'(2I7)') nzlma,lmap(i)
      write(5200+myrank,'(2I7)') nzlma,mmap(i)
      write(5300+myrank,'(2I7)') nzlma,iorbmap(i)
    enddo
  END SUBROUTINE checkMapsBeforeForce

END MODULE ps_nloc2_variables


subroutine incbcc(lundia    ,timnow    ,zmodel    ,nmax      ,mmax      , &
                & kmax      ,nto       ,nrob      ,lstsc     ,noroco    , &
                & tprofc    ,itbcc     ,mnbnd     ,nob       ,kstp      , &
                & kfsmin    ,kfsmax    ,rob       ,rbnd      ,guu       , &
                & gvv       ,dps       ,s0        ,sig       ,procbc    , &
                & zstep     ,dzs1      ,zk        ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: incbcc.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/timedep/incbcc.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: Carry out interpolation in space, determine time
!              increments and updates the time dependent const.
!              BC (if NTO > 0 and LSTSC > 0)
! Method used: - At each time step the increment values are added
!                to update the values at the vertices of the
!                boundaries
!              - Hereafter space interpolation is applied to cal-
!                culate the boundary values at each point.
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use dfparall
    use globaldata
    use m_openda_exchange_items, only : get_openda_buffer
    !
    implicit none
    !
    ! Enumeration
    !
    integer, parameter :: start_pivot = 1
    integer, parameter ::   end_pivot = 2
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    integer                 , pointer :: ltem
    integer                 , pointer :: lsal
    real(fp)                , pointer :: tstop
    integer                 , pointer :: itfinish
    integer                 , pointer :: lunbcc
    logical                 , pointer :: newstp
    real(fp), dimension(:,:), pointer :: dist_pivot_part
!
! Global variables
!
    integer                                                                                :: kmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                                                :: lstsc  !  Description and declaration in dimens.igs
    integer                                                                                :: lundia !  Description and declaration in inout.igs
    integer                                                                                :: mmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                                                :: nmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                                  , intent(in)  :: noroco !  Description and declaration in esm_alloc_int.f90
    integer                                                                  , intent(in)  :: nrob   !  Description and declaration in esm_alloc_int.f90
    integer                                                                                :: nto    !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(7, nto)                                         , intent(in)  :: mnbnd  !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(5, nto, lstsc)                                                :: itbcc  !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(8, nrob)                                        , intent(in)  :: nob    !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)                     :: kfsmax !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)       , intent(in)  :: kfsmin !  Description and declaration in esm_alloc_int.f90
    integer      , dimension(nrob, lstsc)                                                  :: kstp   !  Description and declaration in esm_alloc_int.f90
    logical                                                                  , intent(in)  :: zmodel !  Description and declaration in procs.igs
    real(fp)                                                                               :: timnow !!  Current timestep (multiples of dt)
    real(fp)     , dimension(2, nto, lstsc)                                                :: zstep  !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(4, nto, kmax, lstsc)                                          :: procbc !  Description and declaration in esm_alloc_real.f90
    real(prec)   , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)       , intent(in)  :: dps    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)       , intent(in)  :: s0     !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)       , intent(in)  :: guu    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub)       , intent(in)  :: gvv    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(gdp%d%nlb:gdp%d%nub, gdp%d%mlb:gdp%d%mub, kmax) , intent(in)  :: dzs1   !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(kmax)                                           , intent(in)  :: sig    !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(0:kmax)                                         , intent(in)  :: zk
    real(fp)     , dimension(kmax, max(lstsc, 1), 2, noroco)                               :: rbnd   !  Description and declaration in esm_alloc_real.f90
    real(fp)     , dimension(kmax, nrob)                                                   :: rob    !  Description and declaration in esm_alloc_real.f90
    character(10), dimension(nto, lstsc)                                                   :: tprofc !  Description and declaration in esm_alloc_char.f90
!
! Local variables
!
    integer                                      :: i
    integer                                      :: incx    ! Nr. of grid points-1 (in the x-dir.) between the begin and the end point of an opening section
    integer                                      :: incy    ! Nr. of grid points-1 (in the y-dir.) between the begin and the end point of an opening section
    integer                                      :: istsc   ! Index number of constituent
    integer                                      :: ito     ! Index number of open boundary loc.
    integer                                      :: j       ! Loop variable
    integer                                      :: k       ! Loop counter over KMAX
    integer                                      :: kp      ! First array index of array CIRC pointing to the nr. of row/column in array IROCOL
    integer                                      :: kpc     ! First array index of array CIRC pointing to the column number in arra IROCOL
    integer                                      :: kpp     ! Hulp varible
    integer                                      :: kpr     ! First array index of array CIRC pointing to the row number in array IROCOL
    integer                                      :: kq      ! Second array index of array CIRC pointing to the nr. of row/column in array IROCOL
    integer                                      :: kqc     ! Second array index of array CIRC pointing to the column number in arra IROCOL
    integer                                      :: kqq     ! Hulp varible
    integer                                      :: kqr     ! Second array index of array CIRC pointing to the row number in array IROCOL
    integer                                      :: l       ! Loop variable for constituents
    integer                                      :: maxinc  ! Max. of (INCX,INCY,1)
    integer                                      :: mend    ! End coord. (in the x-dir.) of an open bound. section
    integer                                      :: mp
    integer                                      :: msta    ! Starting coord. (in the x-dir.) of an open bound. section
    integer                                      :: n       ! Loop variable
    integer                                      :: n1      ! Pointer var. relating NOB to MNBND
    integer                                      :: nend    ! End coord. (in the y-dir.) of an open bound. section
    integer                                      :: np
    integer                                      :: nsta    ! Starting coord. (in the y-dir.) of an open bound. section
    integer                                      :: lb      ! lowerboundary of loopcounter
    integer                                      :: ub      ! upperboundary of loopcounter
    integer                                      :: mgg     ! M-coord. of the actual open boundary point, which may differ from the ori- ginal position due to grid staggering
    integer                                      :: ngg     ! N-coord. of the actual open boundary point, which may differ from the ori- ginal position due to grid staggering
    integer                                      :: posrel  ! code denoting the position of the open boundary, related to the complete grid
    logical                                      :: first   ! Flag = TRUE in case a time-dependent file is read for the 1-st time
    real(fp)                                     :: dist    ! Real distance between an open bounda- ry point to the begin point of the related opening section
    real(fp)                                     :: distx   ! Incremental distance (in the x-dir.) between two consecutive open boundary points belonging to the same section
    real(fp)                                     :: disty   ! Incremental distance (in the x-dir.) between two consecutive open boundary points belonging to the same section
    real(fp)                                     :: frac    ! Fraction between DIST and the total length of an opening section
    real(fp)                                     :: guuz1
    real(fp)                                     :: guuz2
    real(fp)                                     :: gvvz1
    real(fp)                                     :: gvvz2
    real(fp)                                     :: h0
    real(fp)                                     :: reldep
    real(fp)                                     :: sigjmp
    real(fp)                                     :: timscl  ! Multiple factor to create minutes from read times
    real(fp)                                     :: totl    ! Actual length of an openbnd. section
    real(fp)                                     :: zcord
    real(fp)                                     :: zjmp
    real(fp), dimension(:, :, :, :), allocatable :: procbc_old
!
!! executable statements -------------------------------------------------------
!
    ltem            => gdp%d%ltem
    lsal            => gdp%d%lsal
    newstp          => gdp%gdincbcc%newstp
    lunbcc          => gdp%gdluntmp%lunbcc
    itfinish        => gdp%gdinttim%itfinish
    tstop           => gdp%gdexttim%tstop
    dist_pivot_part => gdp%gdbcdat%dist_pivot_part
    if (lsal .ne. 0 .or. ltem .ne. 0) then
       allocate(procbc_old(2, nto, kmax, max(lsal,ltem)))
    endif
    !
    ! Initialization local parameters
    ! TIMSCL will not been used in UPDBCC
    !
    first  = .false.
    timscl = 1.0
    !
    ! Update values if necessary
    !
    do ito = 1, nto
       do istsc = 1, lstsc
          !
          ! When using several instances, it is necessary to do a partial rewind of the file since
          ! a newly selected instance has an older time stamp.
          ! Luckily, this file (see updbcc) can be read by record.
          ! So we reset the record pointer to the start record if timnow < itbcc(1,..)
          !
          if (timnow < real(itbcc(1,ito,istsc),fp)) then
              itbcc(5, ito, istsc) = itbcc(3, ito, istsc) - 1

             first = .true.
             call updbcc(lunbcc    ,lundia    ,first     ,itbcc     ,ito       , &
                       & istsc     ,timnow    ,itfinish  ,timscl    , &
                       & nto       ,kmax      ,lstsc     ,procbc    ,tprofc    , &
                       & zstep     ,gdp       )
             !
             ! Now, we have to update procbc(1,:) . Its current value is still the value in the
             ! file at itbcc(1,:)
             !
             do k = 1, kmax
                procbc(1,ito,k,istsc) = procbc(1,ito,k,istsc) +                                                 &
                                      & 2.0_fp*(timnow-0.5_fp - real(itbcc(1,ito,istsc)))*procbc(3,ito,k,istsc)
                procbc(2,ito,k,istsc) = procbc(2,ito,k,istsc) +                                                 &
                                      & 2.0_fp*(timnow-0.5_fp - real(itbcc(1,ito,istsc)))*procbc(4,ito,k,istsc)
             enddo
          endif
          !
          if (timnow > real(itbcc(2, ito, istsc),fp)) then
             zstep(1, ito, istsc) = zstep(2, ito, istsc)
             itbcc(1, ito, istsc) = itbcc(2, ito, istsc)
             !
             ! Read new time step and concentrations data
             !
             call updbcc(lunbcc    ,lundia    ,first     ,itbcc     ,ito       , &
                       & istsc     ,timnow    ,itfinish  ,timscl    , &
                       & nto       ,kmax      ,lstsc     ,procbc    ,tprofc    , &
                       & zstep     ,gdp       )
             newstp = .true.
          endif
          !
          ! interpolation in time
          !
          do k = 1, kmax
             procbc(1, ito, k, istsc) = procbc(1, ito, k, istsc)                &
                                      & + procbc(3, ito, k, istsc)
             procbc(2, ito, k, istsc) = procbc(2, ito, k, istsc)                &
                                      & + procbc(4, ito, k, istsc)
          enddo
       enddo
       !
       ! Overrule procbc(1:2,:) with OpenDA input, if present
       ! this is done for salinity and temperature, if present
       ! note: store this value and reset procbc at the end of this routine.
       ! This is to prevent noise-on-noise since procbc(1:2) is never read from file again
       !
       if (lsal .ne. 0) then
          procbc_old(1:2,ito,1:kmax,lsal) = procbc(1:2,ito,1:kmax,lsal)
          call get_openda_buffer('bound_salt', ito, 2, kmax, procbc(1:2,ito,1:kmax,lsal))
       endif
       if (ltem .ne. 0) then
          procbc_old(1:2,ito,1:kmax,ltem) = procbc(1:2,ito,1:kmax,ltem)
          call get_openda_buffer('bound_temp', ito, 2, kmax, procbc(1:2,ito,1:kmax,ltem))
       endif
    enddo
    !
    ! for all "conservative" constituents
    !
    do l = 1, lstsc
       !
       ! calculate space fraction of opening for function values in hob
       !
       do n = 1, nrob
          n1     = nob(8, n)
          msta   = mnbnd(1, n1)
          nsta   = mnbnd(2, n1)
          mend   = mnbnd(3, n1)
          nend   = mnbnd(4, n1)
          posrel = mnbnd(7, n1)
          incx   = mend - msta
          incy   = nend - nsta
          maxinc = max(1, abs(incx), abs(incy))
          incx   = incx/maxinc
          incy   = incy/maxinc
          !
          ! use coord. at zeta points to calculate the interpolated
          ! values from the two utmost points of the opening
          !
          if (parll) then
             !
             ! If the start point/pivot is outside this partition,
             ! add the distance from that point/pivot to the first point inside this partition
             ! to totl and distl
             !
             totl = dist_pivot_part(start_pivot,n1)
          else
             totl = 0.0_fp
          endif
          dist = totl
          frac = 0.0_fp
          do j = 1, maxinc
             msta  = msta + incx
             nsta  = nsta + incy
             !
             ! In case of a diagonal water level boundary (e.g. south-east):
             ! Pythagoras is used to calculate the distance from xz,yz(m,n) to xz,yz(m+1,n+1):
             !       d_y((m,n),(m+1,n+1)) = 0.5*(guuz(m,n) + guuz(m+1,n+1))
             !       d_x((m,n),(m+1,n+1)) = 0.5*(gvvz(m,n) + gvvz(m+1,n+1))
             !       dist = sqrt(d_x*d_x + d_y*d_y)
             !       Where guuz/gvvz is guu/gvv, extrapolated to the boundary zeta-point (outside the domain),
             !       using the first two guu/gvv inside the domain:
             !       guuz(m,n) = ( 3*guu(m+offm1,n+offn1) - guu(m+offm2,n+offn2) ) / 2
             !       Where the indices offset values offm/n1/2 can have the values 0, 1, 2, 3, depending on:
             !       - the orientation of the open boundary related to the domain
             !         north      boundary: nob(4)=0, nob(6)=2, incy=0
             !         north-east boundary: nob(4)=2, nob(6)=2, incx=-incy
             !         east       boundary: nob(4)=2, nob(6)=0, incx=0
             !         south-east boundary: nob(4)=2, nob(6)=1, incx= incy
             !         south      boundary: nob(4)=0, nob(6)=1, incy=0
             !         south-west boundary: nob(4)=1, nob(6)=1, incx=-incy
             !         west       boundary: nob(4)=1, nob(6)=0, incx=0
             !         north-west boundary: nob(4)=1, nob(6)=2, incx= incy
             !       - The value of incx/incy on diagonal boundaries (+1 or -1)
             ! Assumption: - the grid is more or less cartesian locally
             ! Note:       - incx and incy are -1, 0 or 1
             !             - gvvz is based on 2 gvv values with constant m-index and n-indices difference 1
             !             - guuz is based on 2 guu values with constant n-index and m-indices difference 1
             !             - vertical/horizontal boundaries (north, east, south, west):
             !               - flagged by incx=0 or incy=0
             !               - d_y=0 or d_x=0, so instead of Pythagoras: dist = dist + d_x + d_y
             !                 (guu/gvv are distances and always >0)
             !               - extrapolation of guu/gvv to guuz/gvvz is still needed for the non-zero d_x/d_y
             !
             !
             ! Compute distance in xi-direction
             !
             if (incx == 0) then
                !
                ! east or west boundary
                !
                distx = 0.0_fp
             else
                ngg = nsta
                select case(nob(4,n))
                case (0)
                   if (nob(6,n) == 1) then
                      ! south boundary, gvv(ngg,..) and gvv(ngg+1,..) are inside domain
                      gvvz1 = (3.0_fp*gvv(ngg,msta)      - gvv(ngg+1,msta)     ) / 2.0_fp
                      gvvz2 = (3.0_fp*gvv(ngg,msta-incx) - gvv(ngg+1,msta-incx)) / 2.0_fp
                   elseif (nob(6,n) == 2) then
                      ! north boundary, gvv(ngg-1,..) and gvv(ngg-2,..) are inside domain
                      gvvz1 = (3.0_fp*gvv(ngg-1,msta)      - gvv(ngg-2,msta)     ) / 2.0_fp
                      gvvz2 = (3.0_fp*gvv(ngg-1,msta-incx) - gvv(ngg-2,msta-incx)) / 2.0_fp
                   else
                      ! nob(6) is always 1 or 2 for open boundaries that are not east or west boundaries
                   endif
                case (1)
                   if (nob(6,n) == 1) then
                      ! south-west boundary
                      if (incy > 0) then
                         ! incx<0, msta     : gvv(ngg,..)   and gvv(ngg+1,..) are inside domain
                         !         msta-incx: gvv(ngg-1,..) and gvv(ngg,..)   are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg  ,msta)      - gvv(ngg+1,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg-1,msta-incx) - gvv(ngg  ,msta-incx)) / 2.0_fp
                      else
                         ! incy<0, incx>0, msta     : gvv(ngg,..)   and gvv(ngg+1,..) are inside domain
                         !                 msta-incx: gvv(ngg+1,..) and gvv(ngg+2,..) are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg  ,msta)      - gvv(ngg+1,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg+1,msta-incx) - gvv(ngg+2,msta-incx)) / 2.0_fp
                      endif
                   elseif (nob(6,n) == 2) then
                      ! north-west boundary
                      if (incy > 0) then
                         ! incx>0, msta     : gvv(ngg-1,..) and gvv(ngg-2,..) are inside domain
                         !         msta-incx: gvv(ngg-2,..) and gvv(ngg-3,..) are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg-1,msta)      - gvv(ngg-2,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg-2,msta-incx) - gvv(ngg-3,msta-incx)) / 2.0_fp
                      else
                         ! incy<0, incx<0, msta     : gvv(ngg-1,..) and gvv(ngg-2,..) are inside domain
                         !                 msta-incx: gvv(ngg,..)   and gvv(ngg-1,..) are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg-1,msta)      - gvv(ngg-2,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg  ,msta-incx) - gvv(ngg-1,msta-incx)) / 2.0_fp
                      endif
                   else
                      ! nob(6) is always 1 or 2 for open boundaries that are not east or west boundaries
                   endif
                case (2)
                   if (nob(6,n) == 1) then
                      ! south-east boundary
                      if (incy > 0) then
                         ! incx>0, msta     : gvv(ngg,..)   and gvv(ngg+1,..) are inside domain
                         !         msta-incx: gvv(ngg-1,..) and gvv(ngg,..)   are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg  ,msta)      - gvv(ngg+1,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg-1,msta-incx) - gvv(ngg  ,msta-incx)) / 2.0_fp
                      else
                         ! incy<0, incx<0, msta     : gvv(ngg,..)   and gvv(ngg+1,..) are inside domain
                         !                 msta-incx: gvv(ngg+1,..) and gvv(ngg+2,..) are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg  ,msta)      - gvv(ngg+1,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg+1,msta-incx) - gvv(ngg+2,msta-incx)) / 2.0_fp
                      endif
                   elseif (nob(6,n) == 2) then
                      ! north-east boundary
                      if (incy > 0) then
                         ! incx<0, msta     : gvv(ngg-1,..) and gvv(ngg-2,..) are inside domain
                         !         msta-incx: gvv(ngg-2,..) and gvv(ngg-3,..) are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg-1,msta)      - gvv(ngg-2,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg-2,msta-incx) - gvv(ngg-3,msta-incx)) / 2.0_fp
                      else
                         ! incy<0, incx>0, msta     : gvv(ngg-1,..) and gvv(ngg-2,..) are inside domain
                         !                 msta-incx: gvv(ngg,..)   and gvv(ngg-1,..) are inside domain
                         gvvz1 = (3.0_fp*gvv(ngg-1,msta)      - gvv(ngg-2,msta)     ) / 2.0_fp
                         gvvz2 = (3.0_fp*gvv(ngg  ,msta-incx) - gvv(ngg-1,msta-incx)) / 2.0_fp
                      endif
                   else
                      ! nob(6) is always 1 or 2 for open boundaries that are not east or west boundaries
                   endif
                case default
                   ! nob(4) is always 0, 1 or 2
                endselect
                distx = 0.5_fp * (gvvz1 + gvvz2)
             endif
             !
             ! Compute distance in eta-direction
             !
             if (incy == 0) then
                !
                ! north or south boundary
                !
                disty = 0.0_fp
             else
                mgg = msta
                select case(nob(6,n))
                case (0)
                   if (nob(4,n) == 1) then
                      ! west boundary, guu(..,mgg) and guu(..,mgg+1) are inside domain
                      guuz1 = (3.0_fp*guu(nsta     ,mgg) - guu(nsta     ,mgg+1)) / 2.0_fp
                      guuz2 = (3.0_fp*guu(nsta-incy,mgg) - guu(nsta-incy,mgg+1)) / 2.0_fp
                   elseif (nob(4,n) == 2) then
                      ! east boundary, guu(..,mgg-1) and guu(..,mgg-2) are inside domain
                      guuz1 = (3.0_fp*guu(nsta     ,mgg-1) - guu(nsta     ,mgg-2)) / 2.0_fp
                      guuz2 = (3.0_fp*guu(nsta-incy,mgg-1) - guu(nsta-incy,mgg-2)) / 2.0_fp
                   else
                      ! nob(4) is always 1 or 2 for open boundaries that are not north or south boundaries
                   endif
                case (1)
                   if (nob(4,n) == 1) then
                      ! south-west boundary
                      if (incx > 0) then
                         ! incy<0, nsta     : guu(..,mgg)   and guu(..,mgg+1) are inside domain
                         !         nsta-incy: guu(..,mgg-1) and guu(..,mgg)   are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg)   - guu(nsta     ,mgg+1)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg-1) - guu(nsta-incy,mgg)  ) / 2.0_fp
                      else
                         ! incx<0, incy>0, nsta     : guu(..,mgg)   and guu(..,mgg+1) are inside domain
                         !                 nsta-incy: guu(..,mgg+1) and guu(..,mgg+2) are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg)   - guu(nsta     ,mgg+1)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg+1) - guu(nsta-incy,mgg+2)) / 2.0_fp
                      endif
                   elseif (nob(4,n) == 2) then
                      ! south-east boundary
                      if (incx > 0) then
                         ! incy>0, nsta     : guu(..,mgg-1) and guu(..,mgg-2) are inside domain
                         !         nsta-incy: guu(..,mgg-2) and guu(..,mgg-3) are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg-1) - guu(nsta     ,mgg-2)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg-2) - guu(nsta-incy,mgg-3)) / 2.0_fp
                      else
                         ! incx<0, incy<0, nsta     : guu(..,mgg-1) and guu(..,mgg-2) are inside domain
                         !                 nsta-incy: guu(..,mgg)   and guu(..,mgg-1) are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg-1) - guu(nsta     ,mgg-2)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg)   - guu(nsta-incy,mgg-1)) / 2.0_fp
                      endif
                   else
                      ! nob(4) is always 1 or 2 for open boundaries that are not north or south boundaries
                   endif
                case (2)
                   if (nob(4,n) == 1) then
                      ! north-west boundary
                      if (incx > 0) then
                         ! incy>0, nsta     : guu(..,mgg)   and guu(..,mgg+1) are inside domain
                         !         nsta-incy: guu(..,mgg-1) and guu(..,mgg)   are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg)   - guu(nsta     ,mgg+1)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg-1) - guu(nsta-incy,mgg)  ) / 2.0_fp
                      else
                         ! incx<0, incy<0, nsta     : guu(..,mgg)   and guu(..,mgg+1) are inside domain
                         !                 nsta-incy: guu(..,mgg+1) and guu(..,mgg+2) are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg)   - guu(nsta     ,mgg+1)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg+1) - guu(nsta-incy,mgg+2)) / 2.0_fp
                      endif
                   elseif (nob(4,n) == 2) then
                      ! north-east boundary
                      if (incx > 0) then
                         ! incy<0, nsta     : guu(..,mgg-1) and guu(..,mgg-2) are inside domain
                         !         nsta-incy: guu(..,mgg-2) and guu(..,mgg-3) are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg-1) - guu(nsta     ,mgg-2)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg-2) - guu(nsta-incy,mgg-3)) / 2.0_fp
                      else
                         ! incx<0, incy>0, nsta     : guu(..,mgg-1) and guu(..,mgg-2) are inside domain
                         !                 nsta-incy: guu(..,mgg)   and guu(..,mgg-1) are inside domain
                         guuz1 = (3.0_fp*guu(nsta     ,mgg-1) - guu(nsta     ,mgg-2)) / 2.0_fp
                         guuz2 = (3.0_fp*guu(nsta-incy,mgg)   - guu(nsta-incy,mgg-1)) / 2.0_fp
                      endif
                   else
                      ! nob(4) is always 1 or 2 for open boundaries that are not north or south boundaries
                   endif
                case default
                   ! nob(6) is always 0, 1 or 2
                endselect
                disty = 0.5_fp * (guuz1 + guuz2)
             endif
             if (incx/=0 .and. incy/=0) then
                distx = distx * distx
                disty = disty * disty
                totl  = totl + sqrt(distx + disty)
             else
                ! distx==0 or disty==0
                totl  = totl + distx + disty
             endif
             if (msta==nob(1, n) .and. nsta==nob(2, n)) then
                dist = totl
             endif
          enddo
          if (parll) then
             !
             ! If the end point/pivot is outside this partition,
             ! add the distance from that point/pivot to the last point inside this partition
             ! to totl
             !
             totl = totl + dist_pivot_part(end_pivot,n1)
          endif
          if (totl > 0.) then
             frac = dist/totl
          endif
          !
          ! Interpolate in space constituents along surface and bottom
          !
          do k = 1, kmax
             ! rob   (k,n) = VALPNT(n1,k,l,frac)
             rob(k, n) = procbc(1, n1, k, l)                                    &
                       & + frac*(procbc(2, n1, k, l) - procbc(1, n1, k, l))
          enddo
          !
          ! calculate rbnd array
          ! where nob (4,n) := type of opening and
          !       nob (5,n) := row (conform irocol table)
          !       nob (6,n) := type of opening and
          !       nob (7,n) := column (conform irocol table)
          !
          kpr = nob(4, n)
          kqr = nob(5, n)
          kpc = nob(6, n)
          kqc = nob(7, n)
          kp  = kpr
          kq  = kqr
          kpp = kpc
          kqq = kqc
          !
          ! If row boundary not available then use col boundary
          !
          if (kp*kq == 0) then
             kp  = kpc
             kq  = kqc
             kpp = kpr
             kqq = kqr
          endif
          !
          ! Interpolation in vertical direction
          !
          if (tprofc(n1, l)(1:7) == 'uniform') then
             !
             ! uniform
             ! For all KMAX layers ROB is equal (stored in ROB(1,N))
             !
             do k = 1, kmax
                rbnd(k, l, kp, kq) = rob(1, n)
             enddo
          elseif (tprofc(n1, l)(1:6) == 'linear') then
             !
             ! Linear
             ! Values of bottom and surface will be used to interpolated
             ! for all KMAX layers
             !
             if (zmodel) then
                zcord = 0.
                do k = kfsmin(nsta, msta), kmax
                   if (k==kfsmin(nsta, msta)) then
                      zcord = zcord + .5*dzs1(nsta, msta, k)
                   else
                      zcord = zcord +                                           &
                            & .5*(dzs1(nsta, msta, k - 1) + dzs1(nsta, msta, k))
                   endif
                   reldep = zcord/(real(dps(nsta, msta),fp) + s0(nsta, msta))
                   rbnd(k, l, kp, kq) = rob(kmax, n)                            &
                                      & + reldep*(rob(1, n) - rob(kmax, n))
                enddo
             else
                do k = 1, kmax
                   rbnd(k, l, kp, kq) = rob(kmax, n) + (1. + sig(k))            &
                                      & *(rob(1, n) - rob(kmax, n))
                enddo
             endif
          elseif (tprofc(n1, l)(1:4) == 'step') then
             !
             ! step function
             ! The two values of the Step function are written in
             ! ROB(1,N) and ROB(KMAX,N)
             !
             if (newstp) then
                mp     = nob(1, n)
                np     = nob(2, n)
                h0     = real(dps(np, mp),fp) + s0(np, mp)
                zjmp   = -zstep(1, n1, l)
                sigjmp = zjmp/max(h0, 0.01_fp)
                do k = 1, kmax
                   if (zmodel) then
                      if (zjmp > zk(k)) then
                         kstp(n, l) = k
                         goto 610
                      endif
                   elseif (sigjmp > sig(k)) then
                      kstp(n, l) = max(k - 1, 1)
                      goto 610
                   else
                   endif
                enddo
                kstp(n, l) = kmax
             endif
  610        continue
             do k = 1, kmax
                if (k <= kstp(n, l)) then
                   rbnd(k, l, kp, kq) = rob(1, n)
                else
                   rbnd(k, l, kp, kq) = rob(kmax, n)
                endif
             enddo
          elseif (tprofc(n1, l) == '3d-profile') then
             !
             ! 3D-profile function
             ! The user defined input is stored in ROB for all KMAX
             ! layers
             !
             do k = 1, kmax
                rbnd(k, l, kp, kq) = rob(k, n)
             enddo
          else
          endif
          !
          ! If oblique boundary is defined then fill the
          ! computed RBND also in other direction
          !
          do k = 1, kmax
             if (kpp*kqq /= 0) then
                rbnd(k, l, kpp, kqq) = rbnd(k, l, kp, kq)
             endif
          enddo
       enddo
    enddo
    newstp = .false.
    !
    ! Now reset procbc(1:2)
    !
    if (lsal .ne. 0) then
       procbc(1:2,1:nto,1:kmax,lsal) = procbc_old(1:2,1:nto,1:kmax,lsal)
    endif
    if (ltem .ne. 0) then
       procbc(1:2,1:nto,1:kmax,ltem) = procbc_old(1:2,1:nto,1:kmax,ltem)
    endif
    if (lsal .ne. 0 .or. ltem .ne. 0) then
       deallocate(procbc_old)
    endif
end subroutine incbcc


PROGRAM test_module
!
!  Purpose:
!    To illustrate sharing data via a module.
!
USE shared_data               ! Make data in module "test" visible
IMPLICIT NONE

REAL, PARAMETER :: PI = 3.141592  ! Pi

values = PI * (/ 1., 2., 3., 4., 5. /)

CALL sub1                     ! Call subroutine

END PROGRAM test_module

!*****************************************************************
!*****************************************************************

SUBROUTINE sub1
!
!  Purpose:
!    To illustrate sharing data via a module.
!
USE shared_data               ! Make data in module "test" visible
IMPLICIT NONE

WRITE (*,*) values

END SUBROUTINE sub1


      SUBROUTINE DT_FICONF(Ijproj,Ip,Ipz,It,Itz,Nloop,Irej)

C***********************************************************************
C Treatment of FInal CONFiguration including evaporation, fission and  *
C Fermi-break-up (for light nuclei only).                              *
C Adopted from the original routine FINALE and extended to residual    *
C projectile nuclei.                                                   *
C This version dated 12.12.95 is written by S. Roesler.                *
C***********************************************************************
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)

      DOUBLE PRECISION aif , aizf , akprho , AMELCT , amelec , AMNAMA ,
     &                 AMNTRN , AMPRTN , amrcl , AMUC12 , AMUGEV ,
     &                 AMUNMU , ANGLGB , BEXC12 , COUGFM , dlkprh ,
     &                 DT_RNDM , ELCCGS , ELCMKS , EMVGEV
      DOUBLE PRECISION etaeta , exc , excitf , EXMSAZ , expnuc ,
     &                 FERTHO , frcfll , frmrdc , HLFHLF , ONE , p1in ,
     &                 p1out , p2in , p2out , PFRMAV , prcl , prcl0 ,
     &                 prfrmi , prskin , ptold
      DOUBLE PRECISION ptorcl , rdcore , redctn , redori , skinrh ,
     &                 TINY10 , TINY3 , vrcl , we , wrcl , xm1 , xm2 ,
     &                 ZERO
      INTEGER i , icor , idfsp , idpar , idrcl , idtmp , idxpar ,
     &        idxtmp , Ijproj , ilcopt , inorcl , inuc , Ip , Ipz ,
     &        Irej , irej1 , It , Itz , izdum , j
      INTEGER jchar , jmass , k , kf , m , mo , mo1 , mo2 , nch , nexc ,
     &        nfsp , Nloop , nnchit
      SAVE

      INCLUDE 'inc/dtflka'

      PARAMETER (ZERO=0.0D0,ONE=1.0D0,TINY3=1.0D-3,TINY10=1.0D-10)
      PARAMETER (ANGLGB=5.0D-16)

C event history

      INCLUDE 'inc/dtevt1'
C extended event history
      INCLUDE 'inc/dtevt2'
C rejection counter
      INCLUDE 'inc/dtrejc'
C central particle production, impact parameter biasing
      INCLUDE 'inc/dtimpa'
C treatment of residual nuclei: 4-momenta
      INCLUDE 'inc/dtrnu1'
C treatment of residual nuclei: properties of residual nuclei
      INCLUDE 'inc/dtrnu2'
C statistics: residual nuclei
      INCLUDE 'inc/dtsta2'
C flags for input different options
      INCLUDE 'inc/dtflg1'
C particle properties (BAMJET index convention)
      INCLUDE 'inc/dtpart'

      INCLUDE '(DIMPAR)'
      INCLUDE '(GENSTK)'
      INCLUDE '(RESNUC)'
      PARAMETER (EMVGEV=1.0D-03)
      PARAMETER (AMUGEV=0.93149432D+00)
      PARAMETER (AMPRTN=0.93827231D+00)
      PARAMETER (AMNTRN=0.93956563D+00)
      PARAMETER (AMELCT=0.51099906D-03)
      PARAMETER (ELCCGS=4.8032068D-10)
      PARAMETER (ELCMKS=1.60217733D-19)
      PARAMETER (COUGFM=ELCCGS*ELCCGS/ELCMKS*1.D-07*1.D+13*1.D-09)
      PARAMETER (HLFHLF=0.5D+00)
      PARAMETER (FERTHO=14.33D-09)
      PARAMETER (BEXC12=FERTHO*72.40715579499394D+00)
      PARAMETER (AMUNMU=HLFHLF*AMELCT-BEXC12/12.D+00)
      PARAMETER (AMUC12=AMUGEV-AMUNMU)
      INCLUDE '(NUCDAT)'
      INCLUDE '(PAREVT)'
      INCLUDE '(FHEAVY)'

C event flag
      INCLUDE 'inc/dtevno'

      DIMENSION inuc(2) , idxpar(2) , idpar(2) , aif(2) , aizf(2) ,
     &          amrcl(2) , prcl(2,4) , mo1(2) , mo2(2) , vrcl(2,4) ,
     &          wrcl(2,4) , p1in(4) , p2in(4) , p1out(4) , p2out(4)

      DIMENSION expnuc(2) , exc(2,260) , nexc(2,260)
      LOGICAL llcpot
      DATA exc , nexc/520*ZERO , 520*0/
      DATA expnuc/4.0D-3 , 4.0D-3/

      Irej = 0
      LRClpr = .FALSE.
      LRClta = .FALSE.

C skip residual nucleus treatment if not requested or in case
C of central collisions

      IF ( (.NOT.LEVprt) .OR. (ICEntr.GT.0) .OR. (ICEntr.EQ.-100) .OR.
     &     (ICEntr.EQ.-1) ) RETURN
      DO k = 1 , 2
         idpar(k) = 0
         idxpar(k) = 0
         NTOt(k) = 0
         NTOtfi(k) = 0
         NPRo(k) = 0
         NPRofi(k) = 0
         NN(k) = 0
         NH(k) = 0
         NHPos(k) = 0
         NQ(k) = 0
         EEXc(k) = ZERO
         mo1(k) = 0
         mo2(k) = 0
         DO i = 1 , 4
            vrcl(k,i) = ZERO
            wrcl(k,i) = ZERO
         END DO
      END DO
      nfsp = 0
      inuc(1) = Ip
      inuc(2) = It

      DO i = 1 , NHKk

C number of final state particles
         IF ( ABS(ISThkk(i)).EQ.1 ) THEN
            nfsp = nfsp + 1
            idfsp = IDBam(i)
         END IF

C properties of remaining nucleon configurations
         kf = 0
         IF ( (ISThkk(i).EQ.13) .OR. (ISThkk(i).EQ.15) ) kf = 1
         IF ( (ISThkk(i).EQ.14) .OR. (ISThkk(i).EQ.16) ) kf = 2
         IF ( kf.GT.0 ) THEN
            IF ( mo1(kf).EQ.0 ) mo1(kf) = i
            mo2(kf) = i
C   position of residual nucleus = average position of nucleons
            DO k = 1 , 4
               vrcl(kf,k) = vrcl(kf,k) + VHKk(k,i)
               wrcl(kf,k) = wrcl(kf,k) + WHKk(k,i)
            END DO
C   total number of particles contributing to each residual nucleus
            NTOt(kf) = NTOt(kf) + 1
            idtmp = IDBam(i)
            idxtmp = i
C   total charge of residual nuclei
            NQ(kf) = NQ(kf) + IICh(idtmp)
C   number of protons
            IF ( IDHkk(i).EQ.2212 ) THEN
               NPRo(kf) = NPRo(kf) + 1
C   number of neutrons
            ELSE IF ( IDHkk(i).EQ.2112 ) THEN
               NN(kf) = NN(kf) + 1
C   number of baryons other than n, p
            ELSE IF ( IIBar(idtmp).EQ.1 ) THEN
               NH(kf) = NH(kf) + 1
               IF ( IICh(idtmp).EQ.1 ) NHPos(kf) = NHPos(kf) + 1
            ELSE
C   any other mesons (status set to 1)
C                 WRITE(LOUT,1002) KF,IDTMP
C1002             FORMAT(1X,'FICONF:   residual nucleus ',I2,
C    &                   ' containing meson ',I4,', status set to 1')
               ISThkk(i) = 1
               idtmp = idpar(kf)
               idxtmp = idxpar(kf)
               NTOt(kf) = NTOt(kf) - 1
            END IF
            idpar(kf) = idtmp
            idxpar(kf) = idxtmp
         END IF
      END DO

C reject elastic events (def: one final state particle = projectile)
      IF ( (Ip.EQ.1) .AND. (nfsp.EQ.1) .AND. (idfsp.EQ.Ijproj) ) THEN
         IRExci(3) = IRExci(3) + 1
         GOTO 200
C        RETURN
      END IF

C check if one nucleus disappeared..
C     IF ((IP.GT.1).AND.(NTOT(1).EQ.0).AND.(NTOT(2).NE.0)) THEN
C        DO 5 K=1,4
C           PRCLTA(K) = PRCLTA(K)+PRCLPR(K)
C           PRCLPR(K) = ZERO
C   5    CONTINUE
C     ELSEIF ((IT.GT.1).AND.(NTOT(2).EQ.0).AND.(NTOT(1).NE.0)) THEN
C        DO 6 K=1,4
C           PRCLPR(K) = PRCLPR(K)+PRCLTA(K)
C           PRCLTA(K) = ZERO
C   6    CONTINUE
C     ENDIF

      icor = 0
      inorcl = 0
      DO i = 1 , 2
         DO k = 1 , 4
C get the average of the nucleon positions
            vrcl(i,k) = vrcl(i,k)/MAX(NTOt(i),1)
            wrcl(i,k) = wrcl(i,k)/MAX(NTOt(i),1)
            IF ( i.EQ.1 ) prcl(1,k) = PRClpr(k)
            IF ( i.EQ.2 ) prcl(2,k) = PRClta(k)
         END DO
C mass number and charge of residual nuclei
         aif(i) = DBLE(NTOt(i))
         aizf(i) = DBLE(NPRo(i)+NHPos(i))
         IF ( NTOt(i).GT.1 ) THEN
C masses of residual nuclei in ground state

C           AMRCL0(I) = AIF(I)*AMUAMU+1.0D-3*ENERGY(AIF(I),AIZF(I))
            AMRcl0(i) = aif(i)*AMUC12 + EMVGEV*EXMSAZ(aif(i),aizf(i),
     &                  .TRUE.,izdum)

C masses of residual nuclei
            ptorcl = SQRT(prcl(i,1)**2+prcl(i,2)**2+prcl(i,3)**2)
            amrcl(i) = (prcl(i,4)-ptorcl)*(prcl(i,4)+ptorcl)
            IF ( amrcl(i).GT.ZERO ) amrcl(i) = SQRT(amrcl(i))
            IF ( amrcl(i).LE.ZERO ) THEN

               IF ( IOUlev(3).GT.0 .AND. LPRi.GT.4 ) WRITE (LOUt,99010)
     &              i , prcl(i,1) , prcl(i,2) , prcl(i,3) , prcl(i,4) ,
     &              NTOt
99010          FORMAT (1X,'warning! negative excitation energy',/,I4,
     &                 4E15.4,2I4)
               amrcl(i) = ZERO
               EEXc(i) = ZERO
               IF ( Nloop.LE.500 ) GOTO 100
               IRExci(2) = IRExci(2) + 1
               GOTO 200
            ELSE IF ( (amrcl(i).GT.ZERO) .AND. (amrcl(i).LT.AMRcl0(i)) )
     &                THEN
C*sr
C              WRITE(6,*) NEVHKK,I,NTOT(1),NTOT(2),AMRCL(I),AMRCL0(I)
C*
C*sr 3.3
C              AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
               m = MIN(NTOt(i),260)
               IF ( nexc(i,m).GT.0 ) THEN
                  amrcl(i) = AMRcl0(i) + exc(i,m)/DBLE(nexc(i,m))
C                 WRITE(77,*)' EXC(I,M),NEXC(I,M),M,I',
C    &                         EXC(I,M),NEXC(I,M),M,I
               ELSE
 5                m = m + 1
                  IF ( m.LT.inuc(i) ) THEN
C                       WRITE(77,*)' 2:EXC(I,M),NEXC(I,M),M,I',
C    &                                 EXC(I,M),NEXC(I,M),M,I
                     IF ( nexc(i,m).LE.0 ) GOTO 5
                     amrcl(i) = AMRcl0(i) + exc(i,m)/DBLE(nexc(i,m))
C  A.F.
C                    AMRCL(I) = AMRCL0(I)+EXPNUC(I)*DBLE(NTOT(I))
                  ELSE IF ( inuc(i).GT.NTOt(i) ) THEN
                     amrcl(i) = AMRcl0(i) + expnuc(i)
     &                  *DBLE(MAX(inuc(i)-NTOt(i),0))
C                       WRITE(77,*)' EXPNUC(I),NTOT(I),M,INUC(I)',
C    &                               EXPNUC(I),NTOT(I),M,INUC(I)
                  ELSE
                     amrcl(i) = AMRcl0(i) + 0.5D+00*expnuc(i)
                  END IF
               END IF
C*
               EEXc(i) = amrcl(i) - AMRcl0(i)
C              WRITE(77,*)' ICOR,EEXC(I),AMRCL0(I)',
C    &                      ICOR,EEXC(I),AMRCL0(I)
               icor = icor + i
            ELSE IF ( amrcl(i).GE.2.5D0*AMRcl0(i) ) THEN

               IF ( IOUlev(3).GT.0 .AND. LPRi.GT.4 ) WRITE (LOUt,99020)
     &              i , amrcl(i) , AMRcl0(i) , NTOt , NEVhkk
99020          FORMAT (1X,'warning! too high excitation energy',/,I4,1P,
     &                 2E15.4,3I5)
               amrcl(i) = ZERO
               EEXc(i) = ZERO
               IF ( Nloop.LE.500 ) GOTO 100
               IRExci(2) = IRExci(2) + 1
               GOTO 200
            ELSE
C excitation energies of residual nuclei
               EEXc(i) = amrcl(i) - AMRcl0(i)
C  === A.F. === *
               llcpot = .TRUE.
               ilcopt = 3
               IF ( llcpot ) THEN
                  nnchit = MAX(inuc(i)-NTOt(i),0)
                  IF ( ilcopt.LE.2 ) THEN
C Patch for Fermi momentum reduction correlated with impact parameter:
                     frmrdc = MIN((PFRMAV(inuc(i))/APFrmx)**3,ONE)
                     dlkprh = 0.1D+00 + 0.5D+00/SQRT(DBLE(inuc(i)))
                     akprho = ONE - dlkprh
C f x K rho_cen + (1-f) x 0.5 x K rho_cen = frmrdc x rho_cen
                     frcfll = MAX(2.D+00*frmrdc/akprho-ONE,0.05D+00)
C                    REDORI = 0.75D+00
C                    REDORI = ONE
                     redori = ONE/(frmrdc)**(2.D+00/3.D+00)
                  ELSE
                     dlkprh = ZERO
                     rdcore = 1.14D+00*DBLE(inuc(i))**(ONE/3.D+00)
C  Take out roughly one/half of the skin:
                     rdcore = rdcore - 0.5D+00
                     frcfll = rdcore**3
                     prskin = (rdcore+2.4D+00)**3 - frcfll
                     prskin = 0.5D+00*prskin/(prskin+frcfll)
                     frcfll = ONE - prskin
                     frmrdc = frcfll + 0.5D+00*prskin
CD                    WRITE(77,*)' PRSKIN,FRCFLL',PRSKIN,FRCFLL
                     redori = ONE/(frmrdc)**(2.D+00/3.D+00)
                  END IF
                  IF ( nnchit.GT.0 ) THEN
                     IF ( ilcopt.EQ.1 ) THEN
                        skinrh = ONE - frcfll/(DBLE(inuc(i))-ONE)
                        DO nch = 1 , 10
                           etaeta = (ONE-skinrh**inuc(i)-DBLE(inuc(i))
     &                        *(ONE-frcfll)*(ONE-skinrh))
     &                        /(skinrh**inuc(i)-DBLE(inuc(i))
     &                        *(ONE-frcfll)*skinrh)
                           skinrh = skinrh*(ONE+etaeta)
C                          WRITE(77,*)
C    &               ' SKINRH,NCH,INUC(I),FRCFLL,FRMRDC,APFRMX',
C    &                 SKINRH,NCH,INUC(I),FRCFLL,FRMRDC,APFRMX
                        END DO
                        prskin = skinrh**(nnchit-1)
                     ELSE IF ( ilcopt.EQ.2 ) THEN
                        prskin = ONE - frcfll
                     END IF
                     redctn = ZERO
                     DO nch = 1 , nnchit
                        IF ( DT_RNDM(prfrmi).LT.prskin ) THEN
                           prfrmi = ((ONE-2.D+00*dlkprh)*DT_RNDM(prfrmi)
     &                        )**0.333333333333D+00
                        ELSE
                           prfrmi = (ONE-2.D+00*dlkprh*DT_RNDM(prfrmi))
     &                        **0.333333333333D+00
                        END IF
                        redctn = redctn + prfrmi**2
                     END DO
                     redctn = redctn/DBLE(nnchit)
                  ELSE
                     redctn = 0.5D+00
                  END IF
                  EEXc(i) = EEXc(i)*redctn/redori
                  amrcl(i) = AMRcl0(i) + EEXc(i)
                  prcl(i,4) = SQRT(ptorcl**2+amrcl(i)**2)
               END IF
C  === End A.F. === *
               IF ( ICAsca.EQ.0 ) THEN
C*sr 15.1.
C                 EXPNUC(I) = EEXC(I)/DBLE(NTOT(I))
                  expnuc(i) = EEXc(i)/MAX(1,inuc(i)-NTOt(i))
                  m = MIN(NTOt(i),260)
                  exc(i,m) = exc(i,m) + EEXc(i)
                  nexc(i,m) = nexc(i,m) + 1
               END IF
            END IF
         ELSE IF ( NTOt(i).EQ.1 ) THEN

            IF ( LPRi.GT.4 ) WRITE (LOUt,99030) i
99030       FORMAT (1X,'FICONF:   warning! NTOT(I)=1? (I=',I3,')')
            GOTO 200
         ELSE
            AMRcl0(i) = ZERO
            amrcl(i) = ZERO
            EEXc(i) = ZERO
            inorcl = inorcl + i
         END IF
      END DO

      PRClpr(5) = amrcl(1)
      PRClta(5) = amrcl(2)

      IF ( icor.GT.0 ) THEN
         IF ( inorcl.EQ.0 ) THEN
C one or both residual nuclei consist of one nucleon only, transform
C this nucleon on mass shell
            DO k = 1 , 4
               p1in(k) = prcl(1,k)
               p2in(k) = prcl(2,k)
            END DO
            xm1 = amrcl(1)
            xm2 = amrcl(2)
            CALL DT_MASHEL(p1in,p2in,xm1,xm2,p1out,p2out,irej1)
            IF ( irej1.GT.0 ) THEN

               IF ( LPRi.GT.4 ) WRITE (LOUt,*) 'ficonf-mashel rejection'
               GOTO 200
            END IF
            DO k = 1 , 4
               prcl(1,k) = p1out(k)
               prcl(2,k) = p2out(k)
               PRClpr(k) = p1out(k)
               PRClta(k) = p2out(k)
            END DO
            PRClpr(5) = amrcl(1)
            PRClta(5) = amrcl(2)
         ELSE

            IF ( IOUlev(3).GT.0 .AND. LPRi.GT.4 ) WRITE (LOUt,99040)
     &           NEVhkk , INT(aif(1)) , INT(aizf(1)) , INT(aif(2)) ,
     &           INT(aizf(2)) , AMRcl0(1) , amrcl(1) , amrcl(1)
     &           - AMRcl0(1) , AMRcl0(2) , amrcl(2) , amrcl(2)
     &           - AMRcl0(2)
99040       FORMAT (1X,'FICONF:   warning! no residual nucleus for',
     &              ' correction',/,11X,'at event',I8,
     &              ',  nucleon config. 1:',2I4,' 2:',2I4,
     &              2(/,11X,3E12.3))
            IF ( Nloop.LE.500 ) GOTO 100
            IRExci(1) = IRExci(1) + 1
         END IF
      END IF

C update counter
C     IF (NRESEV(1).NE.NEVHKK) THEN
C        NRESEV(1) = NEVHKK
C        NRESEV(2) = NRESEV(2)+1
C     ENDIF
      NREsev(2) = NREsev(2) + 1
      DO i = 1 , 2
         EXCdpm(i) = EXCdpm(i) + EEXc(i)
         EXCdpm(i+2) = EXCdpm(i+2) + (EEXc(i)/MAX(NTOt(i),1))
         NREsto(i) = NREsto(i) + NTOt(i)
         NREspr(i) = NREspr(i) + NPRo(i)
         NREsnu(i) = NREsnu(i) + NN(i)
         NREsba(i) = NREsba(i) + NH(i)
         NREspb(i) = NREspb(i) + NHPos(i)
         NREsch(i) = NREsch(i) + NQ(i)
      END DO

C evaporation
      IF ( LEVprt ) THEN
         DO i = 1 , 2
C initialize evaporation counter
C !!!!!!!! Aarghh !!!!!!!! This is a major crime, it spoils FLUKA!!!
C           NP = 0
            EEXcfi(i) = ZERO
            IF ( (inuc(i).GT.1) .AND. (aif(i).GT.ONE) .AND.
     &           (EEXc(i).GT.ZERO) ) THEN
C put residual nuclei into DTEVT1
               idrcl = 80000
               jmass = INT(aif(i))
               jchar = INT(aizf(i))
C  the following patch is required to transmit the correct excitation
C   energy to Eventd
               IF ( ITRspt.EQ.1 ) THEN
                  IF ( ABS(amrcl(i)-AMRcl0(i)-EEXc(i)).GT.1.D-04 )
     &                 WRITE (77,*)
     &                         ' DT_FICONF:AMRCL(I),AMRCL0(I),EEXC(I)' ,
     &                        amrcl(i) , AMRcl0(i) , EEXc(i)
                  prcl0 = prcl(i,4)
                  prcl(i,4) = SQRT(amrcl(i)**2+prcl(i,1)**2+prcl(i,2)
     &                        **2+prcl(i,3)**2)
                  IF ( ABS(prcl0-prcl(i,4)).GT.0.1D0 ) THEN

                     IF ( LPRi.GT.4 ) WRITE (LOUt,*)
     &                     ' PRCL(I,4) recalculated :' , prcl0 ,
     &                    prcl(i,4)
                  END IF
               END IF
               CALL DT_EVTPUT(1000,idrcl,mo1(i),mo2(i),prcl(i,1),
     &                        prcl(i,2),prcl(i,3),prcl(i,4),jmass,jchar,
     &                        0)
C*sr 22.6.97
               NOBam(NHKk) = i
C*
               DO j = 1 , 4
                  VHKk(j,NHKk) = vrcl(i,j)
                  WHKk(j,NHKk) = wrcl(i,j)
               END DO
C  interface to evaporation module - fill final residual nucleus into
C  common FKRESN
C   fill resnuc only if code is not used as event generator in Fluka
               IF ( ITRspt.NE.1 ) THEN
                  PXRes = prcl(i,1)
                  PYRes = prcl(i,2)
                  PZRes = prcl(i,3)
                  IBRes = NPRo(i) + NN(i) + NH(i)
                  ICRes = NPRo(i) + NHPos(i)
                  ANOw = DBLE(IBRes)
                  ZNOw = DBLE(ICRes)
                  PTRes = SQRT(PXRes**2+PYRes**2+PZRes**2)
C   ground state mass of the residual nucleus (should be equal to AM0T)

                  AMNres = AMRcl0(i)
#ifdef FOR_FLUKA
                  AMMres = AMNAMA(AMNres,IBRes,ICRes)
#else
C**af added to replace amnama from original DPMJET
                  AMNres = AMMres - ZNOw*amelec + ELBnde(ICRes)
#endif

C  common FKFINU
                  TV = ZERO
C   kinetic energy of residual nucleus
                  TVRecl = prcl(i,4) - amrcl(i)
C   excitation energy of residual nucleus
                  TVCms = EEXc(i)
                  ptold = PTRes
                  PTRes = SQRT(ABS(TVRecl*(TVRecl+2.0D0*(AMMres+TVCms)))
     &                    )
                  IF ( ptold.LT.ANGLGB ) THEN
                     CALL DT_RACO(PXRes,PYRes,PZRes)
                     ptold = ONE
                  END IF
                  PXRes = PXRes*PTRes/ptold
                  PYRes = PYRes*PTRes/ptold
                  PZRes = PZRes*PTRes/ptold
C evaporation
                  we = ONE
C movd from above
                  NP = 0
                  NPHeav = 0
                  LRNfss = .FALSE.
                  LFRagm = .FALSE.
                  CALL EVEVAP(we)

C put evaporated particles and residual nuclei to DTEVT1
                  mo = NHKk
                  CALL DT_EVA2HE(mo,excitf,i,irej1)
               END IF
               EEXcfi(i) = excitf
               EXCeva(i) = EXCeva(i) + excitf
            END IF
         END DO
      END IF

      RETURN

C9998 IREXCI(1) = IREXCI(1)+1
 100  Irej = Irej + 1
 200  LRClpr = .TRUE.
      LRClta = .TRUE.
      Irej = Irej + 1
      END SUBROUTINE


      Subroutine z_Trks(Ierr)
      Implicit NONE
*-------------------------------------------------------------------------------
*
*   Called by z_RecGB to fill tracking info (Commons /zRec03/,/zRec04/)
*
*     INPUT:  NONE
*
*     OUTPUT:
*
*       Ierr:   0  <--> Everything is cosher
*              -1  <--> nTrks in VCTPAR > nT_Max
*
*   Author:   Gennady Briskin, Tel Aviv University
*   Date:     20-Dec-1996
*
*_______________________________________________________________________________
*
#include "partap.inc"
#include "vctrhl.inc"
!  /*    ! Tracking table RAW  */
#include "vcatcal.inc"
!  /*    ! Tracking table RAW at Calorimeter  */
#include "vctpar.inc"
!  /*    ! Tracking table fitted to VERTEX  */
#include "vcparcal.inc"
!  /*    ! Tracking table fitted to VERTEX at Calorimeter  */
*
#include "zdrecgb.inc"
#include "vctvtx.inc"
#include "vcparsec.inc"
#include "vcvtxsec.inc"

*==>  OutPut
      Integer Ierr

*==>  Counters
      Integer jTr,I,J
      Logical OK

*==>  Track-Island matching(VCTDCA)
      Real    ptTr,pTrfull
      Real    A1,A3
      Real    terr1,terr2,terr3,terr4

      Real    DistCA,DCATerr,DCACerr
      Real    Coord(3),DCoord(3)

      Logical L_eTrk

c --- additionals for secondary vertex tracks:
      integer  ind_sec, ic1, ic2
      integer  nsvtx, svtxok(nT_max)
      integer  vtx_id
      integer  nT_sec
      integer  hlid(nT_max)
      real     x_sec, y_sec, z_sec, r_sec

c --- Cut Parameters for BEAM PIPE or CTDINNERWALL
c --- z-vertex range [cm] for secondary vertex tracks
c --- vertices are excluded if (z_sec.lt.ZBPMIN).or.(z_sec.gt.ZBPMAX)
      real       ZBPMIN, ZBPMAX
      parameter (ZBPMIN=-60., ZBPMAX=60.)
c --- approx radial distance of beam pipe [cm]
c --- vertices are excluded if ((r_sec.gt.RBPMIN).and.(r_sec.lt.RBPMAX))
      real       RBPMIN, RBPMAX
      parameter (RBPMIN=5., RBPMAX=9.)
c --- approx radial distance of CTD inner wall [cm]
c --- vertices are excluded if ((r_sec.gt.CTDIWMIN).and.(r_sec.lt.CTDIWMAX))
      real       CTDIWMIN, CTDIWMAX
      parameter (CTDIWMIN=14.,CTDIWMAX=18.)

      logical  secfirst, rnotok
      data secfirst / .true. /

*==>  Ini
      Ierr    = 0

      eTrMat  = 0
      eTrNear = 0
      eTrDCA  = 999.0

*==>  Do we have enough space for tracks ??
      nT      = CouTab(VCTPAR)
      If (nT.GT.nT_Max) Then
       Write(6,*) ' '
       Write(6,*) '*==> z_Trks: more than',nT_Max,' tracks ??'
       Write(6,*) ' '
       Ierr = -1
       Return
      EndIf

*==>  Do we have tracks in this event ??
      If (nT.EQ.0) Return

*==>  get eDIS Track Info.........................
      If (eNdis.GT.0) Then

       Coord( 1) = eXdis
       Coord( 2) = eYdis
       Coord( 3) = eZdis
       DCoord(1) = 5.0
       DCoord(2) = 5.0
       DCoord(3) = 5.0

*==>  Do the match :~)
       Do I=1,nT
        Call VCTDCA(I,Coord,DCoord,DistCA,DCATerr,DCACerr)
        If (DistCA.GE.0..AND.DistCA.LE.eCut_DCA) Then
                eTrMat  = eTrMat + 1
         vcteID(eTrMat) = I
         If (DistCA.LT.eTrDCA) Then
          eTrDCA  = DistCA
          eTrNear = I
         EndIf
        EndIf
       EndDo

      EndIf
*
*==>  Hadronic Track Info
      jTr = 0
      Do 100 I=1,nT
*
       Do J=1,eTrMat
        If(I.EQ.vcteID(J)) GOTO 100
       EndDo
*
       Call FetTab(VCTPAR  ,ID,I)
       Call FetTab(VCPARCAL,ID,I)
       Call NatRel(VCTPAR,VCTPAR_VCTRHL,VCTRHL,OK)
       If ( .NOT. OK ) Then
        Print *,'z_Trks: No such VCTRHL track ',I
        STOP
       End If
*
*==>>  Calculate momentum of the track in the Lab (ZEUS-Note 96-013)
*
       ptTr    = VCTRHL_pgevc/Sqrt(1.0+VCTRHL_tdip**2)
       ptTr    = ptTr*ABS(VCTRHL_qovr/VCTPAR_Par(3))
       pTrfull = ptTr/Sin(VCTPAR_Par(1))

*==>   Calculate momentum error on the track
       A1      = VCTPAR_Par(1)
       A3      = VCTPAR_Par(3)
       terr1   = 1.0/TAN(A1)
       terr2   = 1.0/A3
       terr3   = 2.0*terr1*terr2
       terr4   = pTrfull*Sqrt(VCTPAR_Cov(1)*terr1**2 +
     +                        VCTPAR_Cov(6)*terr2**2 +
     +                        VCTPAR_Cov(4)*terr3
     +                       )

*==>   Track variable
       jTr         = jTr + 1
       vcthID(jTr) = I
       hlid(  jTr) = vctpar_VCTRHL
       pTr(   jTr) = pTrfull
       thTr(  jTr) = VCTPAR_Par(1)
       phTr(  jTr) = VCTPAR_Par(2)
       dpTr(  jTr) = terr4
       swmTr( jTr) = VCPARCAL_KODSWM
*
C ---  AQ modification (trust tracking more in transition region) ---
       IF(mod(swmTr(jTr)/100,10).ge.8) Then
         ptMax_CUT = ptMax_CUT9
       ELSE
         ptMax_CUT = ptMax_CUT7
       ENDIF

       If(mod(swmTr(jTr)/100,10).GE.sl_CUT    .AND.
     &    ptTr                  .GE.ptMin_CUT .AND.
     &    ptTr                  .LE.ptMax_CUT )Then
        qltTr(jTr) = 1
       ELSEIf(mod(swmTr(jTr)/100,10).GE.sl_CUT     .AND.
     &        ptTr                  .GE.ptMin_CUT  .AND.
     &        ptTr                  .LE.muon_Ptmax .AND.
     &        AQ_options                               )Then
        qltTr(jTr) = 2
       Else
        qltTr(jTr) = 0
       EndIf

*
 100  Continue
      nT = jTr
*
c     ===============================================================
c --- if you want also secondary vertex tracks:
      if (sec_vtx_yes) then
         if (secfirst) then
            secfirst = .false.
            ind_sec = getind(VCPARSEC,'VCTRHL')
         endif
c ---  Return if there aren't any secondary vertices
c         if (Coutab(VCPARSEC).EQ.0) RETURN
         if (Coutab(VCPARSEC).EQ.0) goto 222
c --- clear vertex array
         nsvtx = 0
         do i=1,nT_max
            svtxok(i) = 0
         enddo

c --- look for electron track here if hasn't been found in VCTPAR:
c         If ((eNdis.GT.0).and.(eTrNear.eq.0)) Then

c --- which of the secondary vertices are accepted?
         do i=1,Coutab(VCVTXSEC)
            call fettab(VCVTXSEC,id,i)
            x_sec = vcvtxsec_v(1)
            y_sec = vcvtxsec_v(2)
            z_sec = vcvtxsec_v(3)
            r_sec = sqrt(x_sec*x_sec + y_sec*y_sec)
            rnotok = .true.
            if ((r_sec.gt.RBPMIN).and.(r_sec.lt.RBPMAX)) then
               rnotok = .false.
            endif
            if ((r_sec.gt.CTDIWMIN).and.(r_sec.lt.CTDIWMAX)) then
               rnotok = .false.
            endif
            if ((z_sec.lt.ZBPMIN).or.(z_sec.gt.ZBPMAX).or.(rnotok)) then
               nsvtx = nsvtx + 1
               svtxok(nsvtx) = VCVTXSEC_id
            endif
         enddo

c --- grab the tracks (go back to VCTRHL)
         nT_sec = Coutab(VCTRHL)
         Do I=1,nT_sec
            call fettab(VCTRHL,id,i)
            call fettab(VCATCAL,id,i)
            call nafrel(VCTRHL,VCPARSEC_VCTRHL,VCPARSEC,ind_sec,ic1,ic2)
            if (ic1.eq.ic2) then
               call fettab(VCPARSEC,ind_sec,ic1)
               vtx_id = VCPARSEC_ProducedAt
c --- check if vertex not ok, if not goto 200 , ifyes continue
               do j=1,nsvtx
                  if (vtx_id.eq.svtxok(j)) goto 200
               enddo
c --- check if VCTRHL-track no not in VCTPAR, if so, do not take
c        this track but print out error message
               do j=1,nT
                 if (i.eq.hlid(j)) then
                     print*, 'z_Trks> MESSAGE'
                     print*, 'same VCTRHL track pointing to primary ',
     & 'and secondary vertex'
                     goto 200
                  endif
               enddo
*
**-->> Calculate momentum of the track in the Lab (ZEUS-Note 96-013)
*
               ptTr    = VCTRHL_pgevc/Sqrt(1.0+VCTRHL_tdip**2)
               ptTr    = ptTr*ABS(VCTRHL_qovr/VCPARSEC_Par(3))
               pTrfull = ptTr/Sin(VCPARSEC_Par(1))

*-->   Calculate momentum error on the track
               A1      = VCPARSEC_Par(1)
               A3      = VCPARSEC_Par(3)
               terr1   = 1.0/TAN(A1)
               terr2   = 1.0/A3
               terr3   = 2.0*terr1*terr2
               terr4   = pTrfull*Sqrt(VCPARSEC_Cov(1)*terr1**2 +
     +              VCPARSEC_Cov(6)*terr2**2 +
     +              VCPARSEC_Cov(4)*terr3
     +              )

*-->   Track variable
               jTr         = jTr + 1
               if (jTr.gt.nT_max) goto 222
               vcthID(jTr) =  - i
               pTr(   jTr) = pTrfull
               thTr(  jTr) = VCPARSEC_Par(1)
               phTr(  jTr) = VCPARSEC_Par(2)
               dpTr(  jTr) = terr4
               swmTr( jTr) = VCATCAL_KODSWM
*
               If(mod(swmTr(jTr)/100,10).GE.sl_CUT.AND.
     &              ptTr.GE.ptMin_CUT.AND.ptTr.LE.ptMax_CUT )Then
                  qltTr(jTr) = 1
               Else
                  qltTr(jTr) = 0
               EndIf
            endif
*
 200        continue
         enddo
      endif
 222  continue

      if (printflag) then
         print*, 'VCTRHL table:'
         write(*,*) 'ID ,Q,SWM,  P      ,  THE    ,  X,Y,Z on CAL -->'
         Do I=1,Coutab(VCTRHL)
            call fettab(VCTRHL,id,i)
            call fettab(VCATCAL,id,i)
            write(*,231) VCTRHL_ID, vcatcal_q, vcatcal_KODSWM,
     &           vctrhl_pgevc, atan(vctrhl_tdip),
     &           vcatcal_x, vcatcal_y, vcatcal_z
         enddo

         print*, ' '
         print*, 'Track SELECTION'
         write(*,*) 'ID ,Q,SWM,  P      ,  THE    ,  PHI '
         do i=1,nT
         write(*,230) hlid(i),qltTr(i),swmTr(i),pTr(i),thTr(i),phTr(i)
         enddo
         do i=nT+1,jTr
         write(*,230) vcthID(i),qltTr(i),swmTr(i),pTr(i),thTr(i),phTr(i)
         enddo
      endif

      if (jTr.gt.nT_max) then
         print*, 'z_Trks> too many tracks in event: '
         print*, 'z_Trks> only primary vertex Tracks taken '
      else
         nT = jTr
      endif
 230  format (i3,1x,i1,1x,i3,3(f9.4,1x))
 231  format (i3,1x,i2,1x,i3,5(f9.4,1x))
      End


MODULE zdftmx
  USE oce
  USE dom_oce
  USE zdf_oce
  USE lbclnk
  USE eosbn2
  USE phycst
  USE prtctl
  USE in_out_manager
  USE iom
  USE lib_mpp
  USE timing
  USE lib_fortran
  IMPLICIT NONE
  PRIVATE
  PUBLIC :: zdf_tmx
  PUBLIC :: zdf_tmx_init
  PUBLIC :: zdf_tmx_alloc
  LOGICAL, PUBLIC, PARAMETER :: lk_zdftmx = .TRUE.
  REAL(KIND = wp) :: rn_htmx
  REAL(KIND = wp) :: rn_n2min
  REAL(KIND = wp) :: rn_tfe
  REAL(KIND = wp) :: rn_me
  LOGICAL :: ln_tmx_itf
  REAL(KIND = wp) :: rn_tfe_itf
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: en_tmx
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :) :: mask_itf
  REAL(KIND = wp), ALLOCATABLE, SAVE, DIMENSION(:, :, :) :: az_tmx
  CONTAINS
  INTEGER FUNCTION zdf_tmx_alloc()
    ALLOCATE(en_tmx(jpi, jpj), mask_itf(jpi, jpj), az_tmx(jpi, jpj, jpk), STAT = zdf_tmx_alloc)
    IF (lk_mpp) CALL mpp_sum(zdf_tmx_alloc)
    IF (zdf_tmx_alloc /= 0) CALL ctl_warn('zdf_tmx_alloc: failed to allocate arrays')
  END FUNCTION zdf_tmx_alloc
  SUBROUTINE zdf_tmx(kt, p_avm, p_avt, p_avs)
    INTEGER, INTENT(IN) :: kt
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: p_avm
    REAL(KIND = wp), DIMENSION(:, :, :), INTENT(INOUT) :: p_avt, p_avs
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: ztpc
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zkz
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zav_tide
    !$ACC KERNELS
    zav_tide(:, :, :) = MIN(60.E-4, az_tmx(:, :, :) / MAX(rn_n2min, rn2(:, :, :)))
    zkz(:, :) = 0.E0
    DO jk = 2, jpkm1
      zkz(:, :) = zkz(:, :) + e3w_n(:, :, jk) * MAX(0.E0, rn2(:, :, jk)) * rau0 * zav_tide(:, :, jk) * wmask(:, :, jk)
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        IF (zkz(ji, jj) /= 0.E0) zkz(ji, jj) = en_tmx(ji, jj) / zkz(ji, jj)
      END DO
    END DO
    DO jk = 2, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          zav_tide(ji, jj, jk) = zav_tide(ji, jj, jk) * MIN(zkz(ji, jj), 30. / 6.) * wmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (kt == nit000) THEN
      !$ACC KERNELS
      ztpc = 0.E0
      DO jk = 1, jpk
        DO jj = 1, jpj
          DO ji = 1, jpi
            ztpc = ztpc + e3w_n(ji, jj, jk) * e1t(ji, jj) * e2t(ji, jj) * MAX(0.E0, rn2(ji, jj, jk)) * zav_tide(ji, jj, jk) * tmask(ji, jj, jk) * tmask_i(ji, jj)
          END DO
        END DO
      END DO
      ztpc = rau0 / (rn_tfe * rn_me) * ztpc
      !$ACC END KERNELS
      IF (lwp) WRITE(numout, FMT = *)
      IF (lwp) WRITE(numout, FMT = *) '          N Total power consumption by av_tide    : ztpc = ', ztpc * 1.E-12, 'TW'
    END IF
    IF (ln_tmx_itf) CALL tmx_itf(kt, zav_tide)
    !$ACC KERNELS
    DO jk = 2, jpkm1
      DO jj = 1, jpj
        DO ji = 1, jpi
          p_avt(ji, jj, jk) = p_avt(ji, jj, jk) + zav_tide(ji, jj, jk) * wmask(ji, jj, jk)
          p_avs(ji, jj, jk) = p_avs(ji, jj, jk) + zav_tide(ji, jj, jk) * wmask(ji, jj, jk)
          p_avm(ji, jj, jk) = p_avm(ji, jj, jk) + zav_tide(ji, jj, jk) * wmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    CALL iom_put("av_tmx", zav_tide)
    IF (ln_ctl) CALL prt_ctl(tab3d_1 = zav_tide, clinfo1 = ' tmx - av_tide: ', tab3d_2 = p_avt, clinfo2 = ' p_avt: ', kdim = jpk)
  END SUBROUTINE zdf_tmx
  SUBROUTINE tmx_itf(kt, pav)
    INTEGER, INTENT(IN   ) :: kt
    REAL(KIND = wp), INTENT(INOUT), DIMENSION(jpi, jpj, jpk) :: pav
    INTEGER :: ji, jj, jk
    REAL(KIND = wp) :: zcoef, ztpc
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zkz
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zsum1, zsum2, zsum
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zempba_3d_1, zempba_3d_2
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zempba_3d, zdn2dz
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zavt_itf
    !$ACC KERNELS
    zdn2dz(:, :, jpk) = 0.E0
    zempba_3d_1(:, :, jpk) = 0.E0
    zempba_3d_2(:, :, jpk) = 0.E0
    DO jk = 1, jpkm1
      zdn2dz(:, :, jk) = rn2(:, :, jk) - rn2(:, :, jk + 1)
      zempba_3d_1(:, :, jk) = SQRT(MAX(0.E0, rn2(:, :, jk)))
      zempba_3d_2(:, :, jk) = MAX(0.E0, rn2(:, :, jk))
    END DO
    zsum(:, :) = 0.E0
    zsum1(:, :) = 0.E0
    zsum2(:, :) = 0.E0
    DO jk = 2, jpk
      zsum1(:, :) = zsum1(:, :) + zempba_3d_1(:, :, jk) * e3w_n(:, :, jk) * tmask(:, :, jk) * tmask(:, :, jk - 1)
      zsum2(:, :) = zsum2(:, :) + zempba_3d_2(:, :, jk) * e3w_n(:, :, jk) * tmask(:, :, jk) * tmask(:, :, jk - 1)
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        IF (zsum1(ji, jj) /= 0.E0) zsum1(ji, jj) = 1.E0 / zsum1(ji, jj)
        IF (zsum2(ji, jj) /= 0.E0) zsum2(ji, jj) = 1.E0 / zsum2(ji, jj)
      END DO
    END DO
    DO jk = 1, jpk
      DO jj = 1, jpj
        DO ji = 1, jpi
          zcoef = 0.5 - SIGN(0.5, zdn2dz(ji, jj, jk))
          ztpc = zempba_3d_1(ji, jj, jk) * zsum1(ji, jj) * zcoef + zempba_3d_2(ji, jj, jk) * zsum2(ji, jj) * (1. - zcoef)
          zempba_3d(ji, jj, jk) = ztpc
          zsum(ji, jj) = zsum(ji, jj) + ztpc * e3w_n(ji, jj, jk)
        END DO
      END DO
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        IF (zsum(ji, jj) > 0.E0) zsum(ji, jj) = 1.E0 / zsum(ji, jj)
      END DO
    END DO
    zcoef = rn_tfe_itf / (rn_tfe * rau0)
    DO jk = 1, jpk
      zavt_itf(:, :, jk) = MIN(10.E-4, zcoef * en_tmx(:, :) * zsum(:, :) * zempba_3d(:, :, jk) / MAX(rn_n2min, rn2(:, :, jk)) * tmask(:, :, jk))
    END DO
    zkz(:, :) = 0.E0
    DO jk = 2, jpkm1
      zkz(:, :) = zkz(:, :) + e3w_n(:, :, jk) * MAX(0.E0, rn2(:, :, jk)) * rau0 * zavt_itf(:, :, jk) * tmask(:, :, jk) * tmask(:, :, jk - 1)
    END DO
    DO jj = 1, jpj
      DO ji = 1, jpi
        IF (zkz(ji, jj) /= 0.E0) zkz(ji, jj) = en_tmx(ji, jj) * rn_tfe_itf / rn_tfe / zkz(ji, jj)
      END DO
    END DO
    DO jk = 2, jpkm1
      zavt_itf(:, :, jk) = zavt_itf(:, :, jk) * MIN(zkz(:, :), 120. / 10.) * tmask(:, :, jk) * tmask(:, :, jk - 1)
    END DO
    !$ACC END KERNELS
    IF (kt == nit000) THEN
      !$ACC KERNELS
      ztpc = 0.E0
      DO jk = 1, jpk
        DO jj = 1, jpj
          DO ji = 1, jpi
            ztpc = ztpc + e1t(ji, jj) * e2t(ji, jj) * e3w_n(ji, jj, jk) * MAX(0.E0, rn2(ji, jj, jk)) * zavt_itf(ji, jj, jk) * tmask(ji, jj, jk) * tmask_i(ji, jj)
          END DO
        END DO
      END DO
      ztpc = rau0 * ztpc / (rn_me * rn_tfe_itf)
      !$ACC END KERNELS
      IF (lwp) WRITE(numout, FMT = *) '          N Total power consumption by zavt_itf: ztpc = ', ztpc * 1.E-12, 'TW'
    END IF
    !$ACC KERNELS
    DO jk = 2, jpkm1
      pav(:, :, jk) = pav(:, :, jk) * (1.E0 - mask_itf(:, :)) + zavt_itf(:, :, jk) * mask_itf(:, :)
    END DO
    !$ACC END KERNELS
  END SUBROUTINE tmx_itf
  SUBROUTINE zdf_tmx_init
    INTEGER :: ji, jj, jk
    INTEGER :: inum
    INTEGER :: ios
    REAL(KIND = wp) :: ztpc, ze_z
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zem2, zek1
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zkz
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zfact
    REAL(KIND = wp), DIMENSION(jpi, jpj) :: zhdep
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zpc
    REAL(KIND = wp), DIMENSION(jpi, jpj, jpk) :: zav_tide
    NAMELIST /namzdf_tmx/ rn_htmx, rn_n2min, rn_tfe, rn_me, ln_tmx_itf, rn_tfe_itf
    REWIND(UNIT = numnam_ref)
    READ(numnam_ref, namzdf_tmx, IOSTAT = ios, ERR = 901)
901 IF (ios /= 0) CALL ctl_nam(ios, 'namzdf_tmx in reference namelist', lwp)
    REWIND(UNIT = numnam_cfg)
    READ(numnam_cfg, namzdf_tmx, IOSTAT = ios, ERR = 902)
902 IF (ios /= 0) CALL ctl_nam(ios, 'namzdf_tmx in configuration namelist', lwp)
    IF (lwm) WRITE(numond, namzdf_tmx)
    IF (lwp) THEN
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) 'zdf_tmx_init : tidal mixing'
      WRITE(numout, FMT = *) '~~~~~~~~~~~~'
      WRITE(numout, FMT = *) '   Namelist namzdf_tmx : set tidal mixing parameters'
      WRITE(numout, FMT = *) '      Vertical decay scale for turbulence   = ', rn_htmx
      WRITE(numout, FMT = *) '      Brunt-Vaisala frequency threshold     = ', rn_n2min
      WRITE(numout, FMT = *) '      Tidal dissipation efficiency          = ', rn_tfe
      WRITE(numout, FMT = *) '      Mixing efficiency                     = ', rn_me
      WRITE(numout, FMT = *) '      ITF specific parameterisation         = ', ln_tmx_itf
      WRITE(numout, FMT = *) '      ITF tidal dissipation efficiency      = ', rn_tfe_itf
    END IF
    IF (zdf_tmx_alloc() /= 0) CALL ctl_stop('STOP', 'zdf_tmx_init : unable to allocate tmx arrays')
    IF (ln_tmx_itf) THEN
      CALL iom_open('mask_itf', inum)
      CALL iom_get(inum, jpdom_data, 'tmaskitf', mask_itf, 1)
      CALL iom_close(inum)
    END IF
    CALL iom_open('M2rowdrg', inum)
    CALL iom_get(inum, jpdom_data, 'field', zem2, 1)
    CALL iom_close(inum)
    CALL iom_open('K1rowdrg', inum)
    CALL iom_get(inum, jpdom_data, 'field', zek1, 1)
    CALL iom_close(inum)
    !$ACC KERNELS
    en_tmx(:, :) = - rn_tfe * rn_me * (zem2(:, :) * 1.25 + zek1(:, :)) * ssmask(:, :)
    DO jj = 1, jpj
      DO ji = 1, jpi
        zhdep(ji, jj) = gdepw_0(ji, jj, mbkt(ji, jj) + 1)
        zfact(ji, jj) = rau0 * rn_htmx * (1. - EXP(- zhdep(ji, jj) / rn_htmx))
        IF (zfact(ji, jj) /= 0) zfact(ji, jj) = en_tmx(ji, jj) / zfact(ji, jj)
      END DO
    END DO
    DO jk = 1, jpk
      DO jj = 1, jpj
        DO ji = 1, jpi
          az_tmx(ji, jj, jk) = zfact(ji, jj) * EXP(- (zhdep(ji, jj) - gdepw_0(ji, jj, jk)) / rn_htmx) * tmask(ji, jj, jk)
        END DO
      END DO
    END DO
    !$ACC END KERNELS
    IF (nprint == 1 .AND. lwp) THEN
      !$ACC KERNELS
      zav_tide(:, :, :) = 0.E0
      DO jk = 2, jpkm1
        zav_tide(:, :, jk) = az_tmx(:, :, jk) / MAX(rn_n2min, rn2(:, :, jk))
      END DO
      ztpc = 0.E0
      zpc(:, :, :) = MAX(rn_n2min, rn2(:, :, :)) * zav_tide(:, :, :)
      DO jk = 2, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            ztpc = ztpc + e3w_0(ji, jj, jk) * e1t(ji, jj) * e2t(ji, jj) * zpc(ji, jj, jk) * wmask(ji, jj, jk) * tmask_i(ji, jj)
          END DO
        END DO
      END DO
      ztpc = rau0 * 1 / (rn_tfe * rn_me) * ztpc
      !$ACC END KERNELS
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) '          Total power consumption of the tidally driven part of Kz : ztpc = ', ztpc * 1.E-12, 'TW'
      !$ACC KERNELS
      zav_tide(:, :, :) = MIN(zav_tide(:, :, :), 60.E-4)
      zkz(:, :) = 0.E0
      DO jk = 2, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zkz(ji, jj) = zkz(ji, jj) + e3w_0(ji, jj, jk) * MAX(0.E0, rn2(ji, jj, jk)) * rau0 * zav_tide(ji, jj, jk) * wmask(ji, jj, jk)
          END DO
        END DO
      END DO
      DO jj = 1, jpj
        DO ji = 1, jpi
          IF (zkz(ji, jj) /= 0.E0) THEN
            zkz(ji, jj) = en_tmx(ji, jj) / zkz(ji, jj)
          END IF
        END DO
      END DO
      ztpc = 1.E50
      DO jj = 1, jpj
        DO ji = 1, jpi
          IF (zkz(ji, jj) /= 0.E0) THEN
            ztpc = MIN(zkz(ji, jj), ztpc)
          END IF
        END DO
      END DO
      !$ACC END KERNELS
      WRITE(numout, FMT = *) '          Min de zkz ', ztpc, ' Max = ', MAXVAL(zkz(:, :))
      !$ACC KERNELS
      DO jk = 2, jpkm1
        DO jj = 1, jpj
          DO ji = 1, jpi
            zav_tide(ji, jj, jk) = zav_tide(ji, jj, jk) * MIN(zkz(ji, jj), 30. / 6.) * wmask(ji, jj, jk)
          END DO
        END DO
      END DO
      ztpc = 0.E0
      zpc(:, :, :) = MAX(0.E0, rn2(:, :, :)) * zav_tide(:, :, :)
      DO jk = 1, jpk
        DO jj = 1, jpj
          DO ji = 1, jpi
            ztpc = ztpc + e3w_0(ji, jj, jk) * e1t(ji, jj) * e2t(ji, jj) * zpc(ji, jj, jk) * wmask(ji, jj, jk) * tmask_i(ji, jj)
          END DO
        END DO
      END DO
      ztpc = rau0 * 1 / (rn_tfe * rn_me) * ztpc
      !$ACC END KERNELS
      WRITE(numout, FMT = *) '          2 Total power consumption of the tidally driven part of Kz : ztpc = ', ztpc * 1.E-12, 'TW'
      DO jk = 1, jpk
        ze_z = SUM(e1t(:, :) * e2t(:, :) * zav_tide(:, :, jk) * tmask_i(:, :)) / MAX(1.E-20, SUM(e1t(:, :) * e2t(:, :) * wmask(:, :, jk) * tmask_i(:, :)))
        !$ACC KERNELS
        ztpc = 1.E50
        DO jj = 1, jpj
          DO ji = 1, jpi
            IF (zav_tide(ji, jj, jk) /= 0.E0) ztpc = MIN(ztpc, zav_tide(ji, jj, jk))
          END DO
        END DO
        !$ACC END KERNELS
        WRITE(numout, FMT = *) '            N2 min - jk= ', jk, '   ', ze_z * 1.E4, ' cm2/s min= ', ztpc * 1.E4, 'max= ', MAXVAL(zav_tide(:, :, jk)) * 1.E4, ' cm2/s'
      END DO
      WRITE(numout, FMT = *) '          e_tide : ', SUM(e1t * e2t * en_tmx) / (rn_tfe * rn_me) * 1.E-12, 'TW'
      WRITE(numout, FMT = *)
      WRITE(numout, FMT = *) '          Initial profile of tidal vertical mixing'
      DO jk = 1, jpk
        !$ACC KERNELS
        DO jj = 1, jpj
          DO ji = 1, jpi
            zkz(ji, jj) = az_tmx(ji, jj, jk) / MAX(rn_n2min, rn2(ji, jj, jk))
          END DO
        END DO
        !$ACC END KERNELS
        ze_z = SUM(e1t(:, :) * e2t(:, :) * zkz(:, :) * tmask_i(:, :)) / MAX(1.E-20, SUM(e1t(:, :) * e2t(:, :) * wmask(:, :, jk) * tmask_i(:, :)))
        WRITE(numout, FMT = *) '                jk= ', jk, '   ', ze_z * 1.E4, ' cm2/s'
      END DO
      DO jk = 1, jpk
        !$ACC KERNELS
        zkz(:, :) = az_tmx(:, :, jk) / rn_n2min
        !$ACC END KERNELS
        ze_z = SUM(e1t(:, :) * e2t(:, :) * zkz(:, :) * tmask_i(:, :)) / MAX(1.E-20, SUM(e1t(:, :) * e2t(:, :) * wmask(:, :, jk) * tmask_i(:, :)))
        WRITE(numout, FMT = *)
        WRITE(numout, FMT = *) '          N2 min - jk= ', jk, '   ', ze_z * 1.E4, ' cm2/s min= ', MINVAL(zkz) * 1.E4, 'max= ', MAXVAL(zkz) * 1.E4, ' cm2/s'
      END DO
    END IF
  END SUBROUTINE zdf_tmx_init
END MODULE zdftmx


module converr
!$$$   module documentation block
!                .      .    .                                       .
! module:    converr
!   prgmmr: su          org: np2                date: 2007-03-15
! abstract:  This module contains variables and routines related
!            to the assimilation of conventional observations error
!
! program history log:
!   2007-03-15  su  - original code - move reading observation error table
!                                     from read_prepbufr to here so all the
!                                     processor can have the new error information
!
! Subroutines Included:
!   sub converr_read      - allocate arrays for and read in conventional error table
!   sub converr_destroy   - destroy conventional error arrays
!
! Variable Definitions:
!   def etabl             -  the array to hold the error table
!   def ptabl             -  the array to have vertical pressure values
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

use kinds, only:r_kind,i_kind,r_single
use constants, only: zero
use obsmod, only : oberrflg
implicit none

! set default as private
  private
! set subroutines as public
  public :: converr_read
  public :: converr_destroy
! set passed variables as public
  public :: etabl,ptabl

  integer(i_kind),save:: ietabl,itypex,lcount,iflag,k,m
  real(r_single),save,allocatable,dimension(:,:,:) :: etabl
  real(r_kind),save,allocatable,dimension(:)  :: ptabl

contains

  subroutine converr_read(mype)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    convinfo_err      read conventional information file
!
!     prgmmr:    su    org: np2                date: 2007-03-15
!
! abstract:  This routine reads the conventional error table file
!
! program history log:
!   2008-06-04  safford -- add subprogram doc block
!   2013-05-14  guo     -- add status and iostat in open, to correctly
!                          handle the error case of "obs error table not
!                          available to 3dvar".
!   2014-08-14  weir    -- added mype checks to warning statements
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language:  f90
!   machine:   ibm RS/6000 SP
!
!$$$ end documentation block
     use constants, only: half
     implicit none

     integer(i_kind),intent(in   ) :: mype

     integer(i_kind):: ier

     allocate(etabl(300,33,6))

     etabl=1.e9_r_kind

     ietabl=19
     open(ietabl,file='errtable',form='formatted',status='old',iostat=ier)
     if(ier/=0) then
        if(mype == 0) write(6,*)'CONVERR:  ***WARNING*** obs error table ("errtable") not available to 3dvar.'
        lcount=0
        oberrflg=.false.
        return
     endif

     rewind ietabl
     etabl=1.e9_r_kind
     lcount=0
     loopd : do
        read(ietabl,100,IOSTAT=iflag,end=120) itypex
        if( iflag /= 0 ) exit loopd
100     format(1x,i3)
        lcount=lcount+1
        do k=1,33
           read(ietabl,110)(etabl(itypex,k,m),m=1,6)
110        format(1x,6e12.5)
        end do
     end do   loopd
120  continue

     if(lcount<=0 .and. mype==0) then
        if(mype == 0) write(6,*)'CONVERR:  ***WARNING*** obs error table not available to 3dvar.'
        oberrflg=.false.
     else
        if(mype == 0) write(6,*)'CONVERR:  using observation errors from user provided table'
        allocate(ptabl(34))
        ptabl=zero
        ptabl(1)=etabl(120,1,1)
        do k=2,33
           ptabl(k)=half*(etabl(120,k-1,1)+etabl(120,k,1))
        enddo
        ptabl(34)=etabl(120,33,1)
     endif

     close(ietabl)

     return
  end subroutine converr_read

subroutine converr_destroy
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    converr_destroy      destroy conventional information file
!     prgmmr:    su    org: np2                date: 2007-03-15
!
! abstract:  This routine destroys arrays from converr file
!
! program history log:
!   2007-03-15  su
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm rs/6000 sp
!
!$$$
     implicit none

     deallocate(etabl,ptabl)
     return
  end subroutine converr_destroy

end module converr


! Relies on
! - step_type_mod
! - load_param_mod
module disp_mod
use abaqus_utils_mod
implicit none

    private

    public      :: get_bc_rail_rp
    public      :: get_bc_wheel_rp
    public      :: get_bc_wheel_contact

contains

subroutine get_bc_rail_rp(step_type, cycle_nr, time, node_jdof, bc_val)
use step_type_mod, only: STEP_TYPE_ROLLING
use load_param_mod, only: get_rail_rolling_ext, get_rail_noroll_ext
implicit none
    integer, intent(in)                 :: step_type
    integer, intent(in)                 :: cycle_nr
    double precision, intent(in)        :: time(3)
    integer, intent(in)                 :: node_jdof
    double precision, intent(out)       :: bc_val

    double precision                    :: rext, rext_last

    if (node_jdof == 3) then    ! Apply rail extension
        if (step_type == STEP_TYPE_ROLLING) then
            bc_val = get_rail_rolling_ext(time_in_step=time(2))
        else
            bc_val = get_rail_noroll_ext()
        endif
    else
        bc_val = 0.0
    endif

end subroutine get_bc_rail_rp

subroutine get_bc_wheel_rp(step_type, cycle_nr, time, node_jdof, bc_val)
use step_type_mod, only: STEP_TYPE_INITIAL_DEPRESSION, STEP_TYPE_INITIAL_LOAD, STEP_TYPE_ROLLING, &
                         STEP_TYPE_MOVE_BACK, STEP_TYPE_REAPPLY_LOAD, STEP_TYPE_RELEASE_NODES
use load_param_mod, only: is_load_param_read, read_load_params, get_rp_initial_depression_bc, &
                          get_rp_rolling_wheel_bc, get_rp_move_back_bc
implicit none
    integer, intent(in)                 :: step_type
    integer, intent(in)                 :: cycle_nr
    double precision, intent(in)        :: time(3)
    integer, intent(in)                 :: node_jdof
    double precision, intent(out)       :: bc_val

    double precision                    :: time_in_step

    time_in_step = time(2)
    if (step_type == STEP_TYPE_INITIAL_DEPRESSION) then
        ! This step type will occur first, so we will read load params here the first time
        if (.not.is_load_param_read()) then
            call read_load_params()
        endif
        bc_val = get_rp_initial_depression_bc(node_jdof, time_in_step)
    elseif (step_type == STEP_TYPE_INITIAL_LOAD) then
        bc_val = 0.d0
    elseif (step_type == STEP_TYPE_ROLLING) then
        bc_val = get_rp_rolling_wheel_bc(node_jdof, time)
    elseif (step_type == STEP_TYPE_MOVE_BACK) then
        bc_val = get_rp_move_back_bc(node_jdof)
    elseif (step_type == STEP_TYPE_REAPPLY_LOAD) then
        bc_val = 0.d0
    elseif (step_type == STEP_TYPE_RELEASE_NODES) then
        bc_val = 0.d0
    else
        write(*,*) 'bc for wheel rp requested for unsupported step type'
        write(*,"(A,I0)") 'step_type = ', step_type
    endif

end subroutine get_bc_wheel_rp

subroutine get_bc_wheel_contact(step_type, cycle_nr, node_label, node_jdof, bc_val)
use step_type_mod, only : STEP_TYPE_MOVE_BACK, STEP_TYPE_REAPPLY_LOAD
use load_param_mod, only : get_contact_node_bc
implicit none
    integer, intent(in)                 :: step_type
    integer, intent(in)                 :: cycle_nr
    integer, intent(in)                 :: node_label
    integer, intent(in)                 :: node_jdof
    double precision, intent(out)       :: bc_val

    if (any(step_type == [STEP_TYPE_MOVE_BACK, STEP_TYPE_REAPPLY_LOAD])) then
        bc_val = get_contact_node_bc(node_label, node_jdof)
    else
        write(*,*) 'Did not expect request for wheel contact node boundary conditions for'
        write(*,"(A,I0)") 'step of type, step_type = ', step_type
        call xit()
    endif

end subroutine get_bc_wheel_contact

end module