!<arch>
barotropic.f/   843074046   1572  1572  100444  47976     `
c ===========================================================================

c BAROTROPIC.f consists of subroutines which solve the elliptic problem
c       for the barotropic stream function after a coordinate transform
c       to a uniform grid involving the metric terms emx,emy,emxy,emx2 and emy2.
c       Islands are included using line integrals (Kamenkovich) to 
c       set constant values of the streamfunction on multiple land masses.

c       The resulting elliptic equations are solved with Zlatev's Y12M
c       package, by performing an approximate LU factorization and iterating
c       to a predetermined tolerance level

c       Naomi Naik, LDEO, September 17, 1996
c ===========================================================================
c
c 2/24/93  changed call to baro_solv, added iox
c 2/25/93  changed call to baro_solv, added psi
c 2/25/93  changed call to baro_init, added ibar_key
c 3/03/93  got rid of the deph_hx and deph_hy arrays
c 3/08/93  changed call to baro_init, added periodic/non-periodic switch
c 3/10/93  major revision:
c           baro_solv
c                (input)  values of forcing at water and boundary points
c                (output) values of stream function at water and boundry pnts
c           baro_init
c                 (input) number and list of water+boundary points
c                 (input) number and list of boundary points
c                  mask set according to the above list, NOT by using the
c                           depth values
c 3/24/93  changed call to baro_init, including Rayleigh friction and glubina
c          deleted the 'key' parameter, now controlled from mod.in
c 5/18/93  allocation for bound_rhs moved to baro_init 
c 5/20/93  changed call to baro_solv, including Rayleigh friction
c 6/04/93  changed call to baro_init, including nbaro
c                  added subroutine baro_rinit
c 6/29/93  variable depth version
c 7/12/93  fixed to stabilize third order scheme
c 5/12/94  new variable topography
c 3/27/95  fixed 2 memory allocation bugs in "baro_init" & "baro_rinit"
c 7/12/95  added geometric term to time dependent operator, see "mod_rhs"
c                   and "add_dt"
c 7/14/95  all input parameters from "mod.in" and ".y12m" put in common 
c             blocks, for future setting from model_input subroutine
c 7/17/95  rewrote so that differencing is on a uniform grid of unit meshsize
c             with the analytic coordinate transformation factors appearing 
c             in the metric terms emx, emy and emxy, as in main code
c 7/19/95  grid stretching implemented
c             first order derivatives :the stretch factors appear in emx, emy
c             second order derivatives:new terms were added in add_dt,
c             mod_rhs and do_xi_eta
c 12/19/95 grid stretching invoked; baro-parameters are now read and set 
c             in model_input; changed: calls to baro_init, baro_rinit & 
c             baro_solv; debug output has been cleaned /Senya/
c 5/14/96  coriolis function in generalized coordinates from 
c             common/data_geom instead of computed separately here
c 6/19/96  fixed a bug in periodic use of coriolis function 
c 6/19/96  created this stripped down version with reduced memory 
c              (second order, five point stencil only)
c 6/26/96  fixed the sunken island which was spoiled when we imported 
c              the geometric terms 
c 9/17/96  changed all island stuff so it can be specified from input file
c--------------------------------------------------------------------------

      subroutine baro_init (i_p, eps, nxp, nyp, nxyc, iox, nbx, lxx,
     *         nby,lyx, alon, blon, alat, blat, x, y, db, glub)
c----------------------
c     compute the coefficients of the discrete barotropic equations and
c     then perform an approximate lu decomposition

c        ip  = (input) 0: non-periodic in x, 1: periodic in x

c       eps  = (input) effective friction induced by time step
c       nxp  = (input) number of x-coordinate values
c       nyp  = (input) number of y-coordinate values
c       nxyc = (input) number of compressed (water+boundary) points
c       iox  = (input) compressed -> uncompressed
c       nbx  = (input) number of boundary points
c       lxx  = (input) boundary list position -> compressed position
c       alon = (input) minimum longitude
c       blon = (input) maximum longitude
c       alat = (input) minimum latitude 
c       blat = (input) maximum latitude 
c       x    = (input) x coordinate values in degrees
c       y    = (input) y coordinate values in degrees
c       db   = (input) depth values 
c       glub = (input) total depth of ocean
c---------------------------------------------------------------------------
      dimension f(1), emx(1), emy(1), emxy(1), emx2(1), emy2(1), area(1)
      dimension sponge(1), relax(1)
      pointer (p_f, f), (p_emx, emx), (p_emy, emy), (p_emxy, emxy),
     *        (p_emx2, emx2), (p_emy2, emy2), (p_area, area)
     *       , (p_relax, relax), (p_sponge, sponge)
      common/data_geom/ p_f,p_emx,p_emy,p_emxy,p_emx2,p_emy2, p_area
     *       ,p_relax,p_sponge
c---------------------------------------------------------------------------
      include 'barotropic.h'
      
      integer iox(1), lxx(1), lyx(1)
      real    db(1), x(1), y(1)
      integer itmp(1)
      pointer (pitmp, itmp)

      if_per    = i_p
      GLUBINA   = glub

      X_MIN = alon
      X_MAX = blon
      Y_MIN = alat
      Y_MAX = blat

      NX = nxp + 2*if_per
      NY = nyp 
      iper  = nxp

      NXY = NX * NY

      call mem_alloc (pdeph,   NXY, 2, 'baro deph')
      call mem_alloc (pfcor,   NXY, 2, 'baro fcor')
      call mem_alloc (pbemx,   NXY, 2, 'baro emx')
      call mem_alloc (pbemy,   NXY, 2, 'baro emy')
      call mem_alloc (pbemxy,  NXY, 2, 'baro emxy')
      call mem_alloc (pbemxx,  NXY, 2, 'baro emxx')
      call mem_alloc (pbemyy,  NXY, 2, 'baro emyy')
      call mem_alloc (pmask,   NXY, 0, 'baro mask')
      call mem_alloc (pbound_rhs, NXY, 2, 'baro bound rhs')

      do i = 1, NXY
         mask(i) = BC_L
      enddo

      do i = 1, nxyc
         ixy = iox(i)
         ix = mod(ixy-1,nxp)+1
         iy = (ixy-ix)/nxp + 1
         i_xy = (iy - 1)*NX + ix + if_per
         deph(i_xy) = db(i)
         fcor(i_xy)  = f(i)
         bemx(i_xy)  = emx(i)
         bemy(i_xy)  = emy(i)
         bemxy(i_xy) = emxy(i)
         bemxx(i_xy) = emx2(i)
         bemyy(i_xy) = emy2(i)
         mask(i_xy) = BC_W
      enddo

      if (ibar_key .ne. 0) 
     *     open (unit = IUNIT_OUT, file = f_bar(1:n_bar))

      if (ibar_key .eq. 3) then 
         write(IUNIT_OUT, *) 'X-boundary points: i, ix,iy, lxx(i)'
      endif

      do i = 1, nbx
         ixy = iox(lxx(i))
         ix  = mod(ixy-1,nxp)+1
         iy  = (ixy-ix)/nxp + 1
         i_xy = (iy - 1)*NX + ix + if_per
         if (ibar_key .eq. 3) write(IUNIT_OUT,*) i, ix, iy, lxx(i)
         if ( (ix.gt.1.and.ix.lt.nxp) .or. if_per.eq.0) mask(i_xy) = BC_L
      enddo
         
      if (ibar_key .eq. 3) then          
         write(IUNIT_OUT,*)'interior points + X-boundary points 1/2:'
         do iy =  NY, 1, -1
            write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX/2)
         enddo
         write(IUNIT_OUT,*)'interior points + X-boundary points 2/2:'
         do iy =  NY, 1, -1
            write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=NX/2,NX)
         enddo
      
         write(IUNIT_OUT,*) 'Y-boundary points: i, ix, iy, lyx(i)'
      endif

      do i = 1, nby
         ixy = iox(lyx(i))
         ix = mod(ixy-1,nxp)+1
         iy = (ixy-ix)/nxp + 1
         i_xy = (iy - 1)*NX + ix + if_per
         if (ibar_key .eq. 3) write(IUNIT_OUT,*) i, ix, iy, lyx(i)
         mask(i_xy) = BC_L
      enddo

      call mod_open (eps)

      call mod_init(x,y)
      call mod_gra(0)

      if ( ibar_key .eq. 3 ) then
         call mem_alloc (pitmp, NXY, 1, 'BARO iox:')
         do i = 1, nxyc
            ixy = iox(i)
            itmp(ixy) = i
         enddo
         do iy =  NY, 1, -1
            write(IUNIT_OUT, '(200i3)') (mod(itmp(ix+(iy-1)*nxp),1000), ix=1,NX)
         enddo
         call mem_free (pitmp, NXY, 1)
      endif

      call mem_alloc (prelx_p, NPACK, 2, 'baro relx_p')
      call mem_alloc (prelx_m, NPACK, 2, 'baro relx_m')
      call mem_alloc (prely_p, NPACK, 2, 'baro rely_p')
      call mem_alloc (prely_m, NPACK, 2, 'baro rely_m')

      do i = 1, NPACK
         i_xy = list(i)
         ix = mod (i_xy -1 ,NX) + 1
         iy = (i_xy - ix)/NX + 1
         
         relx_p(i) = 1.
         relx_m(i) = 1.
         rely_p(i) = 1.
         rely_m(i) = 1.
         dep = deph(i_xy)
         if (deph(i_xy+1).ge.BAR_DSINK) relx_p(i) = dep/deph(i_xy+1)
         if (mask(i_xy+1).eq.BC_P) relx_p(i) = dep/deph(i_xy+1-iper)
         if (deph(i_xy-1).ge.BAR_DSINK) relx_m(i) = dep/deph(i_xy-1)
         if (mask(i_xy-1).eq.BC_P) relx_m(i) = dep/deph(i_xy-1+iper)
         if (deph(i_xy+NX).ge.BAR_DSINK) rely_p(i) = dep/deph(i_xy+NX)
         if (deph(i_xy-NX).ge.BAR_DSINK) rely_m(i) = dep/deph(i_xy-NX)
      enddo
 
      call mem_alloc(psol,    NXY,   2, 'baro sol')
      call mem_alloc(prhs_bc, NPACK, 2, 'baro rhs_bc')

      if (use_per_island) call mem_alloc(prhs_bc0, NPACK, 2, 'baro rhs_bc0')

      if (use_stan_island) call mem_alloc(prhs_bc1, NPACK, 2, 'baro rhs_bc1')

      call mod_mat

      call mod_lu(0)

      call mem_free (piro, NN12, 1)

      if (ibar_key .ne. 0) call flush(IUNIT_OUT)
      
      return
      end

      subroutine baro_solv (nxp, nyp, nxyc, iox, tb, txb, tyb, psi)
c----------------------
c     compute the barotropic transports, ub, vb, given the depth and
c       the average forcing on a uniform grid, using the lu decomposition
c       from baro_init

c       nxp  = (input) number of x-coordinate values
c       nyp  = (input) number of y-coordinate values
c       nxyc = (input) number of compressed (water) points
c       iox  = (input) compressed -> uncompressed
c       txb  = (input) barotropic forcing, x-direction
c       tyb  = (input) barotropic forcing, y-direction
c       tb   = (input) curl of the barotropic forcing
c       psi  =(output) barotropic stream function, (compressed x)
c----------------------
      include 'barotropic.h'

      real tb(1), txb(1), tyb(1), psi(1)
      integer iox(1)

      call mem_alloc (prhs,  NPACK, 2, 'baro rhs')
      call mem_alloc (ptaux, NPACK, 2, 'baro taux')
      call mem_alloc (ptauy, NPACK, 2, 'baro tauy')

      call do_winds(nxp,nxyc,iox,txb,tyb,psi)

      call mod_rhs (nxp,nxyc,iox,tb)

      call mod_sol

      if (n_sunk.gt.0) then
         do i = 1, NPACK
            i_xy = list(i)
            bound_rhs(i_xy) = rhs(i)
         enddo
      endif

      do i = 1, nxyc
         ixy = iox(i)
         ix = mod(ixy-1,nxp)+1
         iy = (ixy-ix)/nxp + 1
         i_xy = (iy - 1)*NX + ix + if_per
         if (mask(i_xy).eq.BC_W) then
            i_pac = ilst(i_xy)
            dpsi = rhs(i_pac)
         endif
         if (mask(i_xy).eq.BC_P) then
            if (ix.eq.1) then
               i_pac = ilst(i_xy+iper)
               dpsi = rhs(i_pac)
            else
               i_pac = ilst(i_xy-iper)
               dpsi = rhs(i_pac)
            endif
         endif
         if (mask(i_xy).eq.BC_L) dpsi = 0.
         if (mask(i_xy).eq.BC_0) dpsi = b_island(0)
         if (mask(i_xy).eq.BC_1) dpsi = b_island(1)
         psi(i) = dpsi
      enddo

      call mem_free(prhs,  NPACK, 2)
      call mem_free(ptaux, NPACK, 2)
      call mem_free(ptauy, NPACK, 2)

      if (ibar_key .ne. 0) call flush(IUNIT_OUT)

      return
      end


      subroutine mod_open (eps)
c-------------------------------------------      
      include 'barotropic.h'

      CNST_EPS = rayl
      CNST_EPT = eps/nbaro

      if ( ibar_key .gt. 0 ) then
         write (IUNIT_OUT, *)
         write (IUNIT_OUT, *) '        BAROTROPIC SOLVER INFO'
         write (IUNIT_OUT, *) '        ----------------------'
         write (IUNIT_OUT, *)
         write (IUNIT_OUT, *) 'NX,   NY     =', NX, NY 
         write (IUNIT_OUT, *) 'X_MIN, X_MAX =', X_MIN,X_MAX
         write (IUNIT_OUT, *) 'Y_MIN, Y_MAX =', Y_MIN,Y_MAX
         write (IUNIT_OUT, *) 'epsilon      =', CNST_EPT
         write (IUNIT_OUT, *) 'Rayleigh friction=', CNST_EPS
      endif
      return
      end

      
      subroutine mod_init(x,y)
c-------------------------
      include 'barotropic.h'
      dimension x(1),y(1)

c  set various repeated-use vectors
      call extend (x,y)

      if (ibar_key.eq.3) then
         if (NX.gt.80) then
            write(IUNIT_OUT, *) 'masks 1/2 :'
            do iy =  NY, 1, -1
               write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX/2)
            enddo
            write(IUNIT_OUT, *) 'masks 2/2 :'
            do iy =  NY, 1, -1
               write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=NX/2,NX)
            enddo
         else
            write(IUNIT_OUT, *) 'masks:'
            do iy =  NY, 1, -1
               write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX)
            enddo
         endif
      endif

      if (n_sunk.gt.0) then
         call mod_sink
         
         if (ibar_key.eq.3) then
            if (NX.gt.80) then
               write(IUNIT_OUT, *) 'after sinking, masks 1/2 :'
               do iy =  NY, 1, -1
                  write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX/2)
               enddo
               write(IUNIT_OUT, *) 'after sinking, masks 2/2 :'
               do iy =  NY, 1, -1
                  write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=NX/2,NX)
               enddo
            else
               write(IUNIT_OUT, *) 'after sinking, masks:'
               do iy =  NY, 1, -1
                  write(IUNIT_OUT,'(200a1)') (mask(ix+(iy-1)*NX), ix=1,NX)
               enddo
            endif
         endif
      endif
      
      end

      subroutine mod_sink
c-------------------------
c   fictitious domain method
c-------------------------------------      
      include 'barotropic.h'

      do iy = 1, NY
      do ix = 2, NX
         i_xy = (iy - 1) * NX + ix
         if (mask(i_xy).eq.BC_S) then
            deph(i_xy) = BAR_DELTA
            mask(i_xy) = BC_W
c the rest is a cludge - just to fill in these values
            fcor(i_xy)  = fcor(i_xy - 1)
            bemx(i_xy)  = bemx(i_xy - 1)
            bemy(i_xy)  = bemy(i_xy - 1)
            bemxy(i_xy) = bemxy(i_xy - 1)
            bemxx(i_xy) = bemxx(i_xy - 1)
            bemyy(i_xy) = bemyy(i_xy - 1)
         endif
      enddo
      enddo

      end

      subroutine extend (x,y)
c-------------------------
      include 'barotropic.h'
      dimension x(1),y(1)

c  extend east/west boundaries
      if (if_per .eq. 1) then
         ix = 1
         do iy = 1, NY
            i_xy = (iy - 1) * NX + ix
            mask(i_xy) = mask(i_xy+iper)
         enddo
         ix = NX
         do iy = 1, NY
            i_xy = (iy - 1) * NX + ix
            mask(i_xy) = mask(i_xy-iper)
         enddo

         ix = NX
         do iy = 2, NY-1
            i_xy = (iy - 1) * NX + ix
            if (mask(i_xy).eq.BC_W) then
                mask(i_xy) = BC_P
                mask(i_xy-NX+1) = BC_P
            endif
            if (mask(i_xy).eq.BC_L) then
                mask(i_xy-NX+1) = BC_L
            endif
         enddo
      endif

      if (use_per_island) then
         ib = 0
         do iy = 2, NY
            if (y(iy-1).lt.per_lat.and.per_lat.le.y(iy)) ib = iy
         enddo
         iy = ib
         do ix = 1, NX
            i_xy = (iy - 1) * NX + ix
            if (mask(i_xy).ne.BC_W.and.mask(i_xy).ne.BC_P) ib = 0
         enddo
         if (ib.eq.0) then
            print*,'trouble with line integral for periodic island'
            stop
         endif
   10    continue
         do ix = 1, NX
            do iy = 1, NY
               i_xy = (iy - 1) * NX + ix
               dlat = y(iy)
               if ((mask(i_xy).eq.BC_L) 
     *              .and. dlat.lt.per_lat) mask(i_xy) = BC_0
            enddo
         enddo
      endif
      if (use_stan_island) then
         i_max1 = 0
         i_min1 = 0
         j_max1 = 0
         j_min1 = 0
         do ix = 3, NX-1
            xl = x(ix-1 -if_per)
            xr = x(ix   -if_per)
            if (xl.lt.alon1_min.and.alon1_min.le.xr) i_min1 = ix
            if (xl.lt.alon1_max.and.alon1_max.le.xr) i_max1 = ix
         enddo
         do iy = 2, NY
            yl = y(iy-1)
            yr = y(iy)
            if (yl.lt.alat1_min.and.alat1_min.le.yr) j_min1 = iy
            if (yl.lt.alat1_max.and.alat1_max.le.yr) j_max1 = iy
         enddo
         if (j_min1*j_max1*i_min1*i_max1.eq.0) then
            print*,'trouble with line integral for standard island'
            stop
         endif
         do ix = i_min1, i_max1
            do iy = j_min1, j_max1
               i_xy = (iy - 1) * NX + ix
               if ((mask(i_xy).eq.BC_L)) mask(i_xy) = BC_1
            enddo
         enddo
      endif
      
      do i = 1, n_sunk
         i_maxs(i) = 0
         i_mins(i) = 0
         j_maxs(i) = 0
         j_mins(i) = 0
         do ix = 2, NX
            xl = x(ix-1 -if_per)
            xr = x(ix   -if_per)
            if (xl.lt.alons_min(i).and.alons_min(i).le.xr) i_mins(i) = ix
            if (xl.lt.alons_max(i).and.alons_max(i).le.xr) i_maxs(i) = ix
         enddo
         do iy = 2, NY
            yl = y(iy-1)
            yr = y(iy)
            if (yl.lt.alats_min(i).and.alats_min(i).le.yr) j_mins(i) = iy
            if (yl.lt.alats_max(i).and.alats_max(i).le.yr) j_maxs(i) = iy
         enddo
         do ix = i_mins(i), i_maxs(i)
            do iy = j_mins(i), j_maxs(i)
               i_xy = (iy - 1) * NX + ix
               if ((mask(i_xy).eq.BC_L)) mask(i_xy) = BC_S
            enddo
         enddo
      enddo
      
      end
      
      subroutine do_island_init
c-------------------------
      include 'barotropic.h'
      
      a_island(0,0) = 1.
      a_island(0,1) = 0.
      a_island(1,0) = 0.
      a_island(1,1) = 1.

      coef0 = 0.
      coef1 = 0.

c  line integrals - trapezoid rule on uniform grid

      if (use_per_island) then

         iy = ib

         do ix = 2, NX-1
            i_xy = (iy - 1) * NX + ix 
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipyp = ilst(i_xy + NX)
            if (ix.gt.2) then
               ipxm = ilst(i_xy - 1)
            else
               ipxm = ilst(i_xy - 1 + iper)
            endif
            if (ix.lt.NX-1) then
               ipxp = ilst(i_xy + 1)
            else
               ipxp = ilst(i_xy + 1 - iper)
            endif
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hx = 1./bex
            d2 = dep**2
            eps = CNST_EPS + dep*CNST_EPT
            coef0  = coef0 + hx*eps*bey*(rhs0(ipyp)-rhs0(ipac))/d2
            coef0  = coef0 + fc/dep*(rhs0(ipxp)-rhs0(ipxm))/2.
            if (use_stan_island) then
               coef1  = coef1 + hx*eps*bey*(rhs1(ipyp)-rhs1(ipac))/d2
               coef1  = coef1 + fc/dep*(rhs1(ipxp)-rhs0(ipxm))/2.
            endif
         enddo
         
         a_island(0,0) = coef0
         a_island(0,1) = coef1

      endif
         
      if (use_stan_island) then
c  integrate on rectangular path surrounding island
         
         coef0 = 0.
         coef1 = 0.
         i_maxm = i_max1 - 1
         j_maxm = j_max1 - 1
         
         iy = j_max1
         
         s = 0.5
         do ix = i_min1, i_max1
            i_xy = (iy - 1) * NX + ix 
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipyp = ilst(i_xy + NX)
            ipxm = ilst(i_xy - 1)
            ipxp = ilst(i_xy + 1)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hxs = s/bex
            d2 = dep**2
            eps = CNST_EPS + dep*CNST_EPT
            coef1  = coef1 + hxs*eps*bey*(rhs1(ipyp)-rhs1(ipac))/d2
            coef1  = coef1 + s*fc/dep*(rhs1(ipxp)-rhs1(ipxm))/2.
            if (use_per_island) then
               coef0  = coef0 + hxs*eps*bey*(rhs0(ipyp)-rhs0(ipac))/d2
               coef0  = coef0 + s*fc/dep*(rhs0(ipxp)-rhs0(ipxm))/2.
            endif
            s = 1.
            if (ix.eq.i_maxm) s = 0.5
         enddo

         iy = j_min1
         
         s = 0.5
         do ix = i_min1, i_max1
            i_xy = (iy - 1) * NX + ix 
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipym = ilst(i_xy - NX)
            ipxm = ilst(i_xy - 1)
            ipxp = ilst(i_xy + 1)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hxs = s/bex
            d2 = dep**2
            eps = CNST_EPS + dep*CNST_EPT
            coef1  = coef1 - hxs*eps*bey*(rhs1(ipac)-rhs1(ipym))/d2
            coef1  = coef1 - s*fc/dep*(rhs1(ipxp)-rhs1(ipxm))/2.
            if (use_per_island) then
               coef0  = coef0 - hxs*eps*bey*(rhs0(ipac)-rhs0(ipym))/d2
               coef0  = coef0 - s*fc/dep*(rhs0(ipxp)-rhs0(ipxm))/2.
            endif      
            s = 1.
            if (ix.eq.i_maxm) s = 0.5
         enddo
         
         ix = i_max1
         s = 0.5
         do iy = j_min1, j_max1
            i_xy   = (iy - 1) * NX + ix
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipxp = ilst(i_xy + 1)
            ipym = ilst(i_xy - NX)
            ipyp = ilst(i_xy + NX)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hys = s/bey
            d2 = dep**2
            eps = CNST_EPS + dep*CNST_EPT
            coef1  = coef1 + hys*eps*bex*(rhs1(ipxp)-rhs1(ipac))/d2
            coef1  = coef1 - s*fc/dep*(rhs1(ipyp)-rhs1(ipym))/2.
            if (use_per_island) then
               coef0  = coef0 + hys*eps*bex*(rhs0(ipxp)-rhs0(ipac))/d2
               coef0  = coef0 - s*fc/dep*(rhs0(ipyp)-rhs0(ipym))/2.
            endif
            s = 1.
            if (iy.eq.j_maxm) s = 0.5
         enddo
         
         ix = i_min1
         s = 0.5
         do iy = j_min1, j_max1
            i_xy   = (iy - 1) * NX + ix
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipxm = ilst(i_xy - 1)
            ipym = ilst(i_xy - NX)
            ipyp = ilst(i_xy + NX)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hys = s/bey
            eps = CNST_EPS + dep*CNST_EPT
            coef1  = coef1 - hys*eps*bex*(rhs1(ipac)-rhs1(ipxm))/d2
            coef1  = coef1 + s*fc/dep*(rhs1(ipyp)-rhs1(ipym))/2.
            if (use_per_island) then
               coef0  = coef0 - hys*eps*bex*(rhs0(ipac)-rhs0(ipxm))/d2
               coef0  = coef0 + s*fc/dep*(rhs0(ipyp)-rhs0(ipym))/2.
            endif
            s = 1.
            if (iy.eq.j_maxm) s = 0.5
         enddo
         
         a_island(1,0) = coef0
         if (coef1.ne.0) a_island(1,1) = coef1

      endif 

      if ( ibar_key .ge. 1 ) then
         write(IUNIT_OUT, *) 'a_island(2:2)=' 
         write(IUNIT_OUT, *) a_island(0,0),a_island(0,1)
         write(IUNIT_OUT, *) a_island(1,0),a_island(1,1)
      endif


      end


      subroutine do_island_integral
c-------------------------
      include 'barotropic.h'
      dimension b(0:2)

      b(0) = 0.
      b(1) = 0.

      coef  = 0.
      wind = 0.

c  line integrals - trapezoid rule on uniform grid

      if (use_per_island) then
         iy = ib
         
         do ix = 2, NX-1
            i_xy = (iy - 1) * NX + ix 
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipyp = ilst(i_xy + NX)
            if (ix.gt.2) then
               ipxm = ilst(i_xy - 1)
            else
               ipxm = ilst(i_xy - 1 + iper)
            endif
            if (ix.lt.NX-1) then
               ipxp = ilst(i_xy + 1)
            else
               ipxp = ilst(i_xy + 1 - iper)
            endif
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hx = 1./bex
            d2 = dep**2
            wind  = wind + hx * taux(ipac)/ dep
            eps = CNST_EPS + dep*CNST_EPT
            coef  = coef + hx* eps* bey* (rhs(ipyp)-rhs(ipac))/d2
            coef  = coef + fc/dep*(rhs(ipxp)-rhs(ipxm))/2.
         enddo
         
         b(0) = - ( wind + coef ) 
      endif
         
      if (use_stan_island) then
c  integrate on rectangular path surrounding island
         
         coef = 0.
         coef0 = 0.
         coef1 = 0.
         wind = 0.
         i_maxm = i_max1 - 1
         j_maxm = j_max1 - 1
         
         iy = j_max1
         
         s = 0.5
         do ix = i_min1, i_max1
            i_xy = (iy - 1) * NX + ix 
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipxm = ilst(i_xy - 1)
            ipxp = ilst(i_xy + 1)
            ipyp = ilst(i_xy + NX)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hxs = s/bex
            d2 = dep**2
            wind  = wind + hxs * taux(ipac)/ dep
            eps = CNST_EPS + dep*CNST_EPT
            coef0  = coef0 + hxs* eps* bey*(rhs(ipyp)-rhs(ipac))/ d2
            coef1  = coef1 + s* fc/ dep* (rhs(ipxp)-rhs(ipxm))/2.
            s = 1.
            if (ix.eq.i_maxm) s = 0.5
         enddo
         
         iy = j_min1
         
         s = 0.5
         do ix = i_min1, i_max1
            i_xy = (iy - 1) * NX + ix 
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipxm = ilst(i_xy - 1)
            ipxp = ilst(i_xy + 1)
            ipym = ilst(i_xy - NX)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hxs = s/bex
            d2 = dep**2
            wind  = wind - hxs * taux(ipym)/ dep
            eps = CNST_EPS + dep*CNST_EPT
            coef0  = coef0 - hxs* eps* bey*(rhs(ipac)-rhs(ipym))/ d2
            coef1  = coef1 - s * fc/dep*(rhs(ipxp)-rhs(ipxm))/2.
            s = 1.
            if (ix.eq.i_maxm) s = 0.5
         enddo
         
         ix = i_max1
         s = 0.5
         do iy = j_min1, j_max1
            i_xy   = (iy - 1) * NX + ix
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipxp = ilst(i_xy + 1)
            ipym = ilst(i_xy - NX)
            ipyp = ilst(i_xy + NX)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hys = s/bey
            d2 = dep**2
            wind  = wind - hys * tauy(ipac)/ dep
            eps = CNST_EPS + dep*CNST_EPT
            coef0  = coef0 + hys* eps* bex*(rhs(ipxp)-rhs(ipac))/d2
            coef1  = coef1 - s * fc/dep*(rhs(ipyp)-rhs(ipym))/2.
            s = 1.
            if (iy.eq.j_maxm) s = 0.5
         enddo
         
         ix = i_min1
         s = 0.5
         do iy = j_min1, j_max1
            i_xy   = (iy - 1) * NX + ix
            fc = fcor(i_xy)
            ipac = ilst(i_xy)
            ipxm = ilst(i_xy - 1)
            ipym = ilst(i_xy - NX)
            ipyp = ilst(i_xy + NX)
            dep = deph(i_xy)
            bex = bemx(i_xy)
            bey = bemy(i_xy)
            hys = s/bey
            d2 = dep**2
            wind  = wind + hys * tauy(ipxm)/ dep
            eps = CNST_EPS + dep*CNST_EPT
            coef0  = coef0 - hys* eps* bex*(rhs(ipac)-rhs(ipxm))/d2
            coef1  = coef1 + s * fc/dep*(rhs(ipyp)-rhs(ipym))/2.
            s = 1.
            if (iy.eq.j_maxm) s = 0.5
         enddo
         
         b(1) = - ( wind + coef0 + coef1 ) 
         
      endif 

      det = a_island(0,0)*a_island(1,1) - a_island(0,1)*a_island(1,0)
      b_island(0) = (b(0)*a_island(1,1) - b(1)*a_island(0,1)) / det
      b_island(1) = (b(1)*a_island(0,0) - b(0)*a_island(1,0)) / det
      
      if ( ibar_key .ge. 1 ) then
         write(IUNIT_OUT, *) 'b_island = ' 
         write(IUNIT_OUT, *) wind,coef0,coef1
         write(IUNIT_OUT, *) 'setting CNST_T = ', b_island(0), b_island(1)
      endif
      
      end
      
      subroutine mod_mat
c------------------------
c   computes approximate matrix norm
c   sets up sparse matrix aa, using stencils computed 
c   in do_elem*
c   scales all matrix entries in aa by approx. matrix norm
c------------------------
      include 'barotropic.h'

      common /band_local/ iband, iaa

      hx_ave = 0.
      hy_ave = 0.
      do i = 1, NPACK
         i_xy = list(i)
         hx_ave = hx_ave + 1./bemx(i_xy)
         hy_ave = hy_ave + 1./bemy(i_xy)
      enddo
      hx_ave = hx_ave/NPACK
      hy_ave = hy_ave/NPACK


      CNST_2OMEGA = 2. * 2. * PI_MATH / (24. * 3600.) ! 2 * 2*pi/day
      phi_0 = PI_MATH/ 180.* (Y_MIN + Y_MAX) / 2.
      CNST_BETA = CNST_2OMEGA *   cos(phi_0)

      CNST_NORM 
     *   = (GLUBINA*CNST_EPT + CNST_EPS) * (1./hx_ave**2 + 1./hy_ave**2) +
     *     CNST_BETA * GLUBINA / hx_ave / R_EARTH

      do i_xy = 1, NXY
         sol(i_xy) = 0.0
      enddo

      do i = 1, NPACK
         rhs_bc(i) = 0.
         if (use_per_island)  rhs_bc0(i) = 0.
         if (use_stan_island) rhs_bc1(i) = 0.
      enddo

      iaa = 0
      do i_pac = 1, NPACK

         i_xy = list(i_pac)

         call do_xi_eta (i_pac,i_xy,xi,eta)

         call do_elem(i_pac,i_xy,xi,eta)

         call add_dt(i_pac, i_xy)

         iband = 0
         call assem (i_pac,i_xy)

      enddo

      if (iaa .ne. NONZ) then
         print*, 'BARO: The matrix has the wrong size !!!'
         stop
      endif

      end

      subroutine assem (i_pac,i_xy)
c------------------------------
      include 'barotropic.h'

      real*8              ce, cw, cn, cs, csum
      common /matr_local/ ce, cw, cn, cs, csum

      call coef_matr (i_pac, i_xy, csum)
      if (mask(i_xy+1).eq.BC_P) then
         call coef_matr (i_pac, i_xy + 1 - iper, ce)
      else
         call coef_matr (i_pac, i_xy + 1, ce)
      endif
      if (mask(i_xy-1).eq.BC_P) then
         call coef_matr (i_pac, i_xy - 1 + iper, cw)
      else
         call coef_matr (i_pac, i_xy - 1, cw)
      endif
      call coef_matr (i_pac, i_xy + NX, cn)
      call coef_matr (i_pac, i_xy - NX, cs)

      end

      subroutine do_elem(i_pac,i_xy,xi,eta)
c-----------------------------
      include 'barotropic.h'

      real*8              ce, cw, cn, cs, csum
      common /matr_local/ ce, cw, cn, cs, csum
      
      real*8 hinv, gam, am, ac, ap, heps
      real*8 bm, bc, bp

c ............................. x - direction
      
      hinv = bemx(i_xy)
      gam = xi/ hinv

      am = CNST_EPS - (gam-abs(gam))/2.
      ap = CNST_EPS + (gam+abs(gam))/2.
      ac = -(am+ap)
      
      c_h  = hinv* hinv/ CNST_NORM
      ap = c_h * ap
      am = c_h * am
      ac = c_h * ac
      
c ............................. y - direction
      
      hinv = bemy(i_xy)
      gam = eta/ hinv

      bm = CNST_EPS - (gam-abs(gam))/2.
      bp = CNST_EPS + (gam+abs(gam))/2.
      bc = -(bm+bp)

      c_h  = hinv* hinv/ CNST_NORM
      bp = c_h * bp
      bm = c_h * bm
      bc = c_h * bc

c ............................. construct stencil
      
      cw = am
      ce = ap
      cs = bm
      cn = bp
      
      csum = ac + bc

      end

      subroutine add_dt (i_pac, i_xy)
c-----------------------------
      include 'barotropic.h'
      
      common /matr_local/ ce, cw, cn, cs, csum
      real*8              ce, cw, cn, cs, csum

      ix = mod (i_xy -1 ,NX) + 1
      iy = (i_xy - ix)/NX + 1
      dep = deph(i_xy)

      const = 0.5* dep* CNST_EPT/ CNST_NORM

      bex = bemx(i_xy)
      bey = bemy(i_xy)
      hxe = const*bex**2
      hye = const*bey**2
      hxy = const*bemxy(i_xy)*bey
      hxx = const*bemxx(i_xy)*bex
      hyy = const*bemyy(i_xy)*bey

      cea = hxe * (1. + relx_p(i_pac)) + hxx
      cwa = hxe * (1. + relx_m(i_pac)) - hxx
      cna = hye * (1. + rely_p(i_pac)) + hxy + hyy
      csa = hye * (1. + rely_m(i_pac)) - hxy - hyy

      ce = ce + cea
      cw = cw + cwa
      cn = cn + cna
      cs = cs + csa

      csum = csum - (cea + cwa + cna + csa)

      end

      subroutine do_xi_eta (ip,i_xy,xi,eta)
c-----------------------------
      include 'barotropic.h'

      
      bex  = bemx(i_xy)
      bey  = bemy(i_xy)
      bexy = bemxy(i_xy)
      bexx = bemxx(i_xy)
      beyy = bemyy(i_xy)
      
      dep = deph(i_xy)
      
      if (dep.ge.BAR_DSINK) then
         deph_x =bex*(relx_p(ip)-relx_m(ip)) * (relx_p(ip)+relx_m(ip)) / 2.
         deph_y =bey*(rely_p(ip)-rely_m(ip)) * (rely_p(ip)+rely_m(ip)) / 2.
         
         if (mask(i_xy-1).eq.BC_P) then
            f_cmx = fcor(i_xy - 1 + iper)
         else
            f_cmx = fcor(i_xy - 1)
         endif
         if (mask(i_xy+1).eq.BC_P) then
            f_cpx = fcor(i_xy + 1 - iper)
         else
            f_cpx = fcor(i_xy + 1)
         endif
         f_cpy = fcor(i_xy + NX)
         f_cmy = fcor(i_xy - NX)
         
c  calculate H**2 (f/H)x
         fh_x = dep * bex* (f_cpx*relx_p(ip) - f_cmx*relx_m(ip))/ 2.
c  calculate H**2 (f/H)y
         fh_y = dep * bey* (f_cpy*rely_p(ip) - f_cmy*rely_m(ip))/ 2.
         
         xi = CNST_EPS * (deph_x  + bexx)        + fh_y
         eta= CNST_EPS * (deph_y  + beyy + bexy) - fh_x
         
      else                      ! sunken island
         xi = 0.
         eta= 0.
         
      endif
      
      end
      
      subroutine coef_matr (i_pac, i_xy, elem)
c----------------------------------------
      include 'barotropic.h'
      real*8 elem
      common /band_local/ iband, iaa

      solu = 1.

      if (mask(i_xy) .eq. BC_W) then
c   if ocean
         iaa = iaa + 1
         aa(iaa) = real(elem)
         return
      endif

      if (mask(i_xy) .eq. BC_L) then
c   if outer boundary of ocean
         iband = 1
         rhs_bc(i_pac)=rhs_bc(i_pac) - elem * sol(i_xy)
         return
      endif
      if (mask(i_xy) .eq. BC_0) then
         rhs_bc0(i_pac)=rhs_bc0(i_pac) - elem * solu 
         return
      endif
      if (mask(i_xy) .eq. BC_1) then
         rhs_bc1(i_pac)=rhs_bc1(i_pac) - elem * solu 
         return
      endif

      end

      subroutine mod_rhs (nxp,nxyc,iox,tb)
c-------------------------------------------
      include 'barotropic.h'
      real tb(1)
      integer iox(1)
      real tmp1(1)
      pointer (ptmp1, tmp1)

      call mem_alloc (ptmp1, NXY, 2, 'baro tmp1')

      do i = 1, nxyc
       ixy = iox(i)
       ix = mod(ixy-1,nxp)+1
       iy = (ixy-ix)/nxp + 1
       i_xy = (iy - 1)*NX + ix + if_per
       dep = deph(i_xy)
       tmp1(i_xy) = dep * dep * tb(i)
      enddo

      do i_pac = 1, NPACK
         i_xy = list(i_pac)
         ix = mod(i_xy-1, NX) + 1
         iy = (i_xy-ix)/NX + 1

         bw = bound_rhs(i_xy-1)
         be = bound_rhs(i_xy+1)
         if (mask(i_xy-1).eq.BC_P) bw = bound_rhs(i_xy-1+iper)
         if (mask(i_xy+1).eq.BC_P) be = bound_rhs(i_xy+1-iper)
         bn = bound_rhs(i_xy+NX)
         bs = bound_rhs(i_xy-NX)
         bc = bound_rhs(i_xy)

         bex  = bemx(i_xy)
         bey  = bemy(i_xy)
         dep = deph(i_xy)
         
         const = 0.5* dep* CNST_EPT
         hxe = const* bex**2
         hye = const* bey**2
         hxy = const* bemxy(i_xy)*bey
         hxx = const* bemxx(i_xy)*bex
         hyy = const* bemyy(i_xy)*bey
         
         ce = hxe * (1. + relx_p(i_pac)) + hxx
         cw = hxe * (1. + relx_m(i_pac)) - hxx
         cn = hye * (1. + rely_p(i_pac)) + hxy + hyy
         cs = hye * (1. + rely_m(i_pac)) - hxy - hyy
         
         csum = - (ce + cw + cn + cs)
         
         btemp= cw*bw + ce*be + cn*bn + cs*bs + csum*bc
         rhs(i_pac)= btemp
      enddo

      do i = 1, NXY
         bound_rhs(i) = 0.
      enddo
      do i_pac = 1, NPACK
         i = list(i_pac)
         bound_rhs(i) = (rhs(i_pac) + tmp1(i) ) / CNST_NORM
      enddo

      call mem_free (ptmp1, NXY, 2)

      end

      subroutine mod_lu(id)
c--------------------------
c           The contents of NPACK, NONZ, aa, ico, NN12, pivot, sn, a1,
c           columns  1,  3,  4, 6, 7, 8 and 11 of HA,
c           AFLAG(6), IFLAG(1), IFLAG(4) and IFAIL  should
c           not  be  altered  between  calls of y12mfe
c--------------------------
      include 'barotropic.h'
      external icpu_time

      real b1(1), sol1(1)
      pointer (pb1, b1), (psol1,sol1)

      data M12_HA /13/

      call mem_alloc (pb1,   NPACK, 2, 'baro b1')
      call mem_alloc (psol1, NPACK, 2, 'baro sol1')

      if ( id .eq. 0) then
         call mem_alloc (pa1,    NONZ,         2, 'baro a1')
         call mem_alloc (psn,    NONZ,         2, 'baro sn')
         call mem_alloc (pha,    NPACK*M12_HA, 2, 'baro ha')
         call mem_alloc (ppivot, NPACK,        2, 'baro pivot')
         call mem_alloc (prhs0,  NPACK,        2, 'baro rhs0')
         call mem_alloc (prhs1,  NPACK,        2, 'baro rhs1')
      endif

c    modify rhs to include non-zero dirichlet boundary conditions

      if (use_per_island) then
         do i = 1, NPACK
            rhs0(i) = rhs_bc0(i)
         enddo
      endif

      NN12 = NONZ * RM12_NN

      call mem_realloc (piro, NGRAPH, NN12, NONZ, 1)
      if (id .eq. 0) then
         call mem_realloc (pico, NGRAPH, NN12, NONZ, 1)
         call mem_realloc (paa,  NGRAPH, NN12, NONZ, 2)
      endif

      itime = icpu_time()
      if ( ibar_key.ge.1 ) then
         write(IUNIT_OUT, *) 
         write(IUNIT_OUT, *)  'LU factorization:'
         write(IUNIT_OUT, *) 'NPACK, NONZ, NN12 = ', NPACK, NONZ, NN12 
      endif

      if (ibar_key .eq. 11) then ! output the matrix for separate analyses
c         open (unit=12, file = 'matr', form = 'unformatted')
         open (unit=12, file = 'matr', form = 'formatted')
         write(12,*) NPACK, NONZ, NN12 
         write(12,*) (iflag(i),i=1,8)
         write(12,*) (aflag(i),i=1,8)
         write(12,*) 'aa:'
         write(12,*) (aa(i),i=1,NONZ)
         write(12,*) 'iro:'
         write(12,*) (iro(i),i=1,NONZ)
         write(12,*) 'ico:'
         write(12,*) (ico(i),i=1,NONZ)
         close(12)
         stop
      endif


      iflag(5) = 2
      call y12mfe(NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, 
     *             ha, NPACK, rhs0, b1, sol1, pivot, aflag, iflag, ifail) 
      iflag(5) = 3

      if (ibar_key.ge.1) then
         write(IUNIT_OUT, *) 'growth factor =',aflag(5)
         write(IUNIT_OUT, *) 'minimal pivotal element =',aflag(8)
         write(IUNIT_OUT, *) 'max number of non-zero elements needed ',
     *          'in array aa =',iflag(8)
         write(IUNIT_OUT, *) 'if this last number was much smaller than'
     *             ,NN12,', reduce NN12'
      endif

      if (ifail .ne. 0) goto 10

      itime = (icpu_time() - itime) / 1000000
      if (ibar_key.ge.1) then
         write(IUNIT_OUT, *) 
         write(IUNIT_OUT, *) 'CPU time for LU factorization was',itime,' sec'
      endif


      if (use_per_island) then
         if (ibar_key.ge.1) then
            write(IUNIT_OUT, *)
            write(IUNIT_OUT, *)"ANTARCTICA"
            write(IUNIT_OUT, *)'number of iterations performed =',iflag(12)
            write(IUNIT_OUT, *)'max-norm of last correction vector =',aflag(9)
            write(IUNIT_OUT, *)'max-norm of last residual vector =',aflag(10)
            write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11)
         endif
         do i = 1, NPACK
            rhs0(i) = sol1(i)
         enddo
      endif

      if (use_stan_island) then
         do i = 1, NPACK
            rhs1(i) = rhs_bc1(i)
         enddo
         
         call y12mfe (NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, 
     *        ha, NPACK, rhs1, b1, sol1, pivot, aflag, iflag, ifail) 
         if (ibar_key.ge.1) then
            write(IUNIT_OUT, *)
            write(IUNIT_OUT, *)"ISLAND1"
            write(IUNIT_OUT, *)'number of iterations performed =',iflag(12)
            write(IUNIT_OUT, *)'max-norm of last correction vector =',aflag(9)
            write(IUNIT_OUT, *)'max-norm of last residual vector =',aflag(10)
            write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11)
         endif
         
         do i = 1, NPACK
            rhs1(i) = sol1(i)
         enddo
      endif
         
   10 if (ifail .ne. 0) then
         print*, 'BARO:   !!! Error code from Y12M:',ifail
         stop
      endif

      if (use_per_island.or.use_stan_island) call do_island_init

      call mem_free (pb1,   NPACK, 2)
      call mem_free (psol1, NPACK, 2)

      if ( id .eq. 0) then
         call mem_free (prhs1, NPACK, 2)
      endif

      end

      subroutine mod_sol
c--------------------------
      include 'barotropic.h'

      real b1(1), sol1(1)
      pointer (pb1, b1), (psol1,sol1)

c    modify rhs to include non-zero dirichlet boundary conditions
      do i = 1, NPACK
        i_xy = list(i)
        rhs0(i) = bound_rhs(i_xy) + rhs_bc(i)
      enddo

      call mem_alloc (pb1,   NPACK, 2, 'baro b1')
      call mem_alloc (psol1, NPACK, 2, 'baro sol1')

      if (ibar_key.ge.2) then
         write(IUNIT_OUT, *) 
         write(IUNIT_OUT, *)  'Baro_solv:'
      endif

c  solve once to get the solution for zero boundary condition,
c   in order to determine b_island
      call y12mfe(NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, 
     *             ha, NPACK, rhs0, b1, sol1, pivot, aflag, iflag, ifail) 

      if (ifail .ne. 0) goto 10

      if (ibar_key.ge.2) then
         write(IUNIT_OUT, *)'number of iterations performed =',       iflag(12)
         write(IUNIT_OUT, *)'max-norm of last correction vector =',   aflag(9)
         write(IUNIT_OUT, *)'max-norm of last residual vector =',     aflag(10)
         write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11)
      endif

      do i = 1, NPACK
         rhs(i) = sol1(i)
         rhs0(i) = b1(i)
      enddo


c  correct for the island influence, using a_island
      if (use_per_island.or.use_stan_island) then
         call do_island_integral
         
         if (use_per_island) then
            do i = 1, NPACK
               rhs0(i) = rhs0(i) + rhs_bc0(i)*b_island(0)
            enddo
         endif
         if (use_stan_island) then
            do i = 1, NPACK
               rhs0(i) = rhs0(i) + rhs_bc1(i)*b_island(1)
            enddo
         endif

         call y12mfe (NPACK, aa, ico, NN12, iro, NN12, a1, sn, NONZ, 
     *        ha, NPACK, rhs0, b1, sol1, pivot, aflag, iflag, ifail) 
         
         if (ibar_key.ge.2) then
            write(IUNIT_OUT, *)
            write(IUNIT_OUT, *)"correcting for island influence"
            write(IUNIT_OUT, *)'number of iterations performed =',       iflag(12)
            write(IUNIT_OUT, *)'max-norm of last correction vector =',   aflag(9)
            write(IUNIT_OUT, *)'max-norm of last residual vector =',     aflag(10)
            write(IUNIT_OUT, *)'max-norm of corrected solution vector =',aflag(11)
         endif
         
         do i = 1, NPACK
            rhs(i) = sol1(i)
         enddo
         
      endif
      
      call mem_free (pb1,   NPACK, 2)
      call mem_free (psol1, NPACK, 2)
      
   10 if (ifail .ne. 0) then
         print*, 'BARO:  !!! Error code from Y12M:',ifail
         stop
      endif

      end

      subroutine mod_gra(id)
c-------------------------
      include 'barotropic.h'

      if (id.eq.0) then
         call init_pack
      endif
      call to_y12m(id)

      end

      subroutine init_pack
c---------------------------
      include 'barotropic.h'

      NPACK = 0

      do i = 1, NXY
         if (mask(i) .eq. BC_W) NPACK = NPACK + 1
      enddo
      
      call mem_alloc (plist, NPACK, 1, 'baro list')
      call mem_alloc (pilst, NXY,   1, 'baro ilst')

      n = 0
      do i = 1, NXY
         if (mask(i) .eq. BC_W) then
            n = n + 1
            list(n) = i
            ilst(i) = n
         endif
      enddo

      end

      subroutine to_y12m(id)
c------------------------
      include 'barotropic.h'

      NGRAPH = NPACK * 5
      call mem_alloc (piro, NGRAPH, 1, 'baro iro')
      if ( id .eq. 0 ) then
         call mem_alloc (pico, NGRAPH, 1, 'baro ico')
         call mem_alloc (paa,  NGRAPH, 2, 'baro aa')
      endif

      NONZ = 0
      do k = 1, NPACK
         call do_adj1(k)
      enddo
      end

      subroutine do_adj1 (k)
c---------------------------------------
      include 'barotropic.h'

      i = list(k)
      call add_to_graph (k, i)
      if (mask(i+1) .eq. BC_P) then
         call add_to_graph (k, i + 1 - iper)
      else
         call add_to_graph (k, i + 1)
      endif
      if (mask(i-1) .eq. BC_P) then
         call add_to_graph (k, i - 1 + iper)
      else
         call add_to_graph (k, i - 1)
      endif
      call add_to_graph (k, i + NX)
      call add_to_graph (k, i - NX)

      end

      subroutine add_to_graph (k, i)
c--------------------------------
      include 'barotropic.h'
      
      ii = ilst(i)
      if (ii .ne. 0) then
         NONZ = NONZ + 1
         iro(NONZ) = k
         ico(NONZ) = ii
      endif
      end

      subroutine baro_rinit (eps)
c----------------------
c     recompute the coefficients of the discrete barotropic equations and
c       then perform an approximate lu decomposition
c       eps  = (input) effective friction induced by time step
c----------------------
      include 'barotropic.h'
      
      CNST_EPS = rayl
      CNST_EPT = eps/nbaro

      if (ibar_key .ge. 1) then
         write (IUNIT_OUT, *)
         write (IUNIT_OUT, *) 'rinit: epsilon      =', CNST_EPT
         write (IUNIT_OUT, *) 'rinit: Rayleigh friction=', CNST_EPS
      endif

      call mod_gra(1)

      call mod_mat

      call mod_lu(1)

      call mem_free(piro, NN12,  1)

      end

      subroutine do_winds (nxp,nxyc,iox,txb,tyb,psi)
c----------------------
      include 'barotropic.h'

      real txb(1), tyb(1), psi(1)
      integer iox(1)
      real tmp1(1)
      pointer (ptmp1, tmp1)

      call mem_alloc (ptmp1, NXY, 2, 'baro tmp1')

      do i = 1, nxyc
         ixy = iox(i)
         ix = mod(ixy-1,nxp)+1
         iy = (ixy-ix)/nxp + 1
         i_xy = (iy - 1)*NX + ix + if_per
         bound_rhs(i_xy) = psi(i)
      enddo
 
      if (use_per_island.or.use_stan_island) then
      do i = 1, nxyc
         ixy = iox(i)
         ix = mod(ixy-1,nxp)+1
         iy = (ixy-ix)/nxp + 1
         i_xy = (iy - 1)*NX + ix + if_per
         tmp1(i_xy) = txb(i)
      enddo

      do i_pac = 1, NPACK
         i_xy = list(i_pac)

         bc  = tmp1(i_xy)
         bn  = tmp1(i_xy+NX)
         bnn = bn
         if (mask(i_xy+NX).eq.BC_W) bnn = tmp1(i_xy+NX+NX)
         bs  = tmp1(i_xy-NX)
 
c         taux(i_pac) = (7.*(bn + bc) - (bnn + bs) ) / 12.
         taux(i_pac) = (bn + bc) / 2.
      enddo

      do i = 1, nxyc
         ixy = iox(i)
         ix = mod(ixy-1,nxp)+1
         iy = (ixy-ix)/nxp + 1
         i_xy = (iy - 1)*NX + ix + if_per
         tmp1(i_xy) = tyb(i)
      enddo

      do i_pac = 1, NPACK
         i_xy = list(i_pac)

         bc  = tmp1(i_xy)
         be  = tmp1(i_xy+1)
         bee = be
         if (mask(i_xy+1).eq.BC_W) bee = tmp1(i_xy+2)
         if (mask(i_xy-1).eq.BC_P) bw = tmp1(i_xy-1+iper)
         if (mask(i_xy+1).eq.BC_P) then
            be = tmp1(i_xy+1-iper)
            bee = tmp1(i_xy+2-iper)
         endif
 
c         tauy(i_pac) = (7.*(be + bc) - (bee + bw) ) / 12.
         tauy(i_pac) = (be + bc) / 2.
      enddo

      h2y = 2 * hy

      do i_pac = 1, NPACK
         i_xy = list(i_pac)
         ix = mod(i_xy-1, NX) + 1
         iy = (i_xy-ix)/NX + 1
         bex = bemx(i_xy)
         bey = bemy(i_xy)
         be = bound_rhs(i_xy+1)
         if (mask(i_xy+1).eq.BC_P) be = bound_rhs(i_xy+1-iper)
         bn = bound_rhs(i_xy+NX)
         bc = bound_rhs(i_xy)
         taux(i_pac) = taux(i_pac) - bey* CNST_EPT*(bn - bc)
         tauy(i_pac) = tauy(i_pac) + bex* CNST_EPT*(be - bc)
      enddo
      else
         do i_pac = 1, NPACK
            taux(i_pac) = 0.
            tauy(i_pac) = 0.
         enddo
      endif

      call mem_free (ptmp1, NXY, 2)

      end
dyn_amlice.f/   843575125   1572  1572  100444  31555     `
c =======================================================================
c
c AMLICE is consists of subroutines that allow to extent the AML of Seager et al.
c to an ice covered ocean. Moreover, the 1D thermodynamic properties of the 
c ice such as thickness, heat content and concentration
c are computed using a Hibler-Oberhuber type formulation
c
c the main subroutine is called HTFLUXICE
c which uses a 1-D thermodynamical ice model called ICETHERMO
c and a modified AML called HTFLUXI that calls several solvers
c note that one was changed slightly to accomodate arbitray array sizes
c
c all temperatures are in KELVIN !!!!
c
c you need to dimension all paramter given by ??
c
c Martin Visbeck and Bob Newton, LDEO, August 22, 1996
c
c===========================================================================

	subroutine htfluxice(mx,my,nx,ny,lsm,dxd,dyd,slat,tstep,
     +         sst,cldfr,wspd,u,v,q,t,rlh,sh,qlw,qsw,pp,qa,th,rh,
     +  sss,qisw,ppi,hice,cice,thice,tsnw,qios,brne,rlhi,shi,qlwi,qswi,
     +  rlc0ice,cpc0ice,qlwice1,qlwice2)
c
c====6===1=========2=========3=========4=========5=========6========7==2
c  This subroutine computes the surface fluxes of a mixed ice-ocean interface.
c  The ice model is thermodynamic only, i.e. not ice moves.
c  The atmospheric boundary layer model is a modifyed version from Seager et al.
c  and the ice model is constructed after Oberhuber et al.
c
c  All temperatures are in Kelvin.
c

C  Input fields:
c
c -GRID
c   mx,my : dimension of arrays
c   nx,ny : size of the used parts of the array
c   lsm   : land sea mask (1=land, 0=ocean/ice)
c   dxd,dyd : grid spacing [degree]
c   slat  : southern latitude of grid [degree]
c
c   tstep :delta time [s]
c 
c -AML+ICE
c   sst   : sea surface temp [K]
c   cldfr : cloud fraction [0-1] (used for longwave radiation only)
c   wspd  : wind speed [m/s]
c   u     : zonal wind [m/s]
c   v     : meridional wind [m/s]
c   q     : observed humidity [kg/kg]
c   t     : observed temperature [K]
c
c -ICE    
c   sss   : sea surface salinity [psu]
c   qisw  : cloud (but not albedo) corrected incomming short wave radiation [W/m^2]
c   ppi   : precipitation [m/s]

C Output fields:
c
c -ATMOS-OCEAN FLUXES
c   rlh   : latent heat flux [W/m^2]
c   sh    : sensible heat flux [W/m^2]
c   qlw   : long wave net radiation [W/m^2]
c   qsw   : short wave (including albedo) [W/m^2]
c   pp    : precip only over water [m/s]
c -ICE-OCEAN FLUXES    
c   qios  : ice-ocean flux [W/m^2]
c   brne  : fresh water flux melt/freeze [m/s]
c

C Additional output for diagnosis
c
c -AML
c   th    : aml potential temperature [K]
c   qa    : aml humidity [kg/kg]
c   rh    : aml relative humidity [0-1]
c -ICE
c   hice  : ice thickness averaged over grid point [m]
c   cice  : ice concentration [0-1]
c   tsnw  : `snow' temperature [K]
c   thice  : ice `heat content' [Km] 
c -ATMOS-ICE FLUXES
c   rlhi  : latent heat flux ice-atmos [W/m^2] 
c   shi   : sensible heat flux ice-atmos [W/m^2]
c   qlwi  : long wave net eadiation ice-atmos [W/m^2]
c   qswi  : short wave (incl. albedo ice-atmos [W/m^2]
c
c -ATMOS-ICE FLUX parts
c   rlc0ice :
c   cpcoice :
c   qlwice1 :
c   qlwice2 :
c   
c

C The net heat flux into the ocean is given by:
c
c  Qnet = rlh+sh+qlw+qsw+qios
c
C The net fresh water flux into the ocean is given by:
c
c  Fnet = fac*rlh + pp + brne
c
c  whith fac=-1/(Qlat*rho_ocean)
c  where Qlat: latent heat of fusion [2.5e6 J/kg]
c  and rho_ocean: reference density for ocean [1000 kg/m^3]
c
c Ice properties:
c  The mean ice temperature can be calculated by
c           ticem=thice/hice*cice+tfreeze
c  The actual ice thickness can be calculated by
c           hicea=hice/cice
c  The ice volume by
c           icevol=hice*dyd*dxd

c
c  Several parameter are taken from include file !!??
c
      include 'amlice.h'

      dimension qisw(mx,my),cldfr(mx,my),wspd(mx,my),u(mx,my),v(mx,my),
     +        ppi(mx,my)
      dimension lsm(mx,my),dyd(my),dxd(mx,my),q(mx,my),t(mx,my)
      dimension sst(mx,my),sss(mx,my)
      dimension rlh(mx,my),sh(mx,my),qlw(mx,my),qsw(mx,my),pp(mx,my)
      dimension qa(mx,my),th(mx,my),rh(mx,my)
      dimension hice(mx,my), cice(mx,my), thice(mx,my), tsnw(mx,my) 
      dimension rlhi(mx,my),shi(mx,my),qlwi(mx,my),qswi(mx,my),
     +           brne(mx,my),qios(mx,my)
      dimension rlc0ice(mx,my),cpc0ice(mx,my),
     +               qlwice1(mx,my),qlwice2(mx,my)
c
c
c  Additional arrays internally used only
c
      dimension aiflux(4)

c
      if (mx.lt.nx.or.my.lt.ny) stop 'atmosice: dimens. mx,my to small'
c
c  avoid problems with zero time step
c
        tstep=max(1e-8,tstep) 

c
c  First call atmospheric heat fluxes assuming to old ice concentration
c      

       call  htfluxi(sst,tsnw,cice,u,v,wspd,lsm,q,t,cldfr,
     +     sh,rlh,qlw,qa,th,rh,rlc0ice,cpc0ice,qlwice1,qlwice2,
     +     slat,dxd,dyd,nx,ny,mx,my)

 
c Loop to call 1D thermodynamic ice model
c

      do 10 ix=1,nx
      do 10 iy=1,ny
c
c check for land or no ice possible
c
	 if (sst(ix,iy).gt.ssticemax .or. lsm(ix,iy).eq.1) then
	    
c
c set output for no-ice situation
c
	    pp(ix,iy)=ppi(ix,iy)
	    qsw(ix,iy)=qisw(ix,iy)*(1-albedoocean)
	    qios(ix,iy)=0.
	    brne(ix,iy)=0.
	    hice(ix,iy)=0.
	    thice(ix,iy)=0.
	    tsnw(ix,iy)=th(ix,iy)
	    cice(ix,iy)=0.
	    rlhi(ix,iy)=0.
	    shi(ix,iy)=0.
	    qlwi(ix,iy)=0.
	    qswi(ix,iy)=0.
	    
	 else
c
c      -atmos-ice flux parts (sensible, latent, shortwave, longwave)
c       full flux given by aiflux(1)+aiflux(2)*tsnow+aiflux(3)*qs(tsnow)
c
	    t1=qlwice1(ix,iy)-qlwice2(ix,iy)*th(ix,iy) 
	    t2=-rlc0ice(ix,iy)*qa(ix,iy)                 
	    t3=-cpc0ice(ix,iy)*th(ix,iy)
	    albedo=albedoocean+(albedoice-albedoocean)*
     +           exp((tsnw(ix,iy)-tfreeze)/albedof)
	    aiflux(1)=t1+t2+t3+qisw(ix,iy)*(1-albedo) 
	    aiflux(2)=cpc0ice(ix,iy)+qlwice2(ix,iy)
	    aiflux(3)=rlc0ice(ix,iy)
	    
c      -atmos-ice precip
	    aiflux(4)=ppi(ix,iy)
	    
c
c    call 1D ice-thermodynamic model
c
	    call icethermo(tsnw(ix,iy),tstep,
	1	 sst(ix,iy),sss(ix,iy),aiflux,thice(ix,iy),hice(ix,iy),
	2	 cice(ix,iy),qios(ix,iy),brne(ix,iy),niter,qsice)
	    
c
c      set atmos-ocean fluxes up
c
	    sh(ix,iy)=sh(ix,iy)*(1-cice(ix,iy))
	    rlh(ix,iy)=rlh(ix,iy)*(1-cice(ix,iy))
	    qlw(ix,iy)=qlw(ix,iy)*(1-cice(ix,iy))
	    qsw(ix,iy)=qisw(ix,iy)*(1-cice(ix,iy))*(1-albedoocean)
	    pp(ix,iy)=ppi(ix,iy)*(1-cice(ix,iy))
c
c      set atmos-ice fluxes up
c
	    shi(ix,iy)=cpc0ice(ix,iy)*(tsnw(ix,iy)-th(ix,iy))*cice(ix,iy)
	    rlhi(ix,iy)=rlc0ice(ix,iy)*(qsice-qa(ix,iy))*cice(ix,iy)
	    qlwi(ix,iy)=(qlwice1(ix,iy)+qlwice2(ix,iy)*
	1	 (tsnw(ix,iy)-th(ix,iy)))*cice(ix,iy)
	    
c
c      compute temperature dependent albedo
c        albedo decays exponentially from ocean to ice value for snow
c        temperatures below freezing with a decayscale given by
c        albedof [1/K]
c
	    
	    albedo=albedoocean+(albedoice-albedoocean)*
     +           exp((tsnw(ix,iy)-tfreeze)/albedof)
	    qswi(ix,iy)=qisw(ix,iy)*cice(ix,iy)*(1-albedo)
c
	 endif
   10	continue
	
	return
	end                                                          
c 
c===============================================================================
c
c
      subroutine icethermo(tsnw,tstep,
     +  sst,sss,aiflux,thice,hice,cice,qios,brne,iter,qsice)

c
c=======================================================================
c  A simple 1D-thermodynamic ice model.                                =
c  Closely follows the physics of Hibler and Oberhuber                 =
c                                                                      =
c  Solves for ice temperature, growth and melt.                        =
c  A timestep, and atmospheric fluxes are specified, hopefully by an   =
c  atmospheric model.                                                  =
c                                                                      =
c=======================================================================
c                                                                      =
c                                 tair                                 =
c                                                                      =
c   ---- qas (atm-ice flx) ----------------                            =
c                              tsnw        |hsnow                      =
c   ---- qsi (=qas) -----------------------                            =
c                              tice        |                           =
c                                          |                           =
c        qif (ice)                         |                           =
c                              tfreeze     |                           =
c   -----qio (ice-ocean)-----------------------------------------------=
c                               SST                                    =
c=======================================================================
c   final ice-ocean heat flux    : qios           [W/m**2)]     =
c   final freshwater flux        : brne           [m/s]         =
c   grid mean ice thickness      : hice           [m]           =
c   fraction of grid ice covered : cice           fraction      =
c   mean 'heat' content if ice   : thice          [K*m]         =
c                                                               =
c   note that hsnow is fixed and has no heat content ....       =
c                                                               =
c======================================================================
	
	
c  --- Set some constants for the run from include file !!??
	
	include 'amlice.h'
	
	
	dimension  aiflux(4)
c    aiflux(1-3) is used ti evaluate the ice-atmos heat flux
c    aiflux(4) is precip
c    dqmax is the maximum missfit in W/m^2 between ice-snow and atmos-snow flux
	
	
c======================================================================
	
	
c  --- ice-ocean heat flux
c      modeled as a conductive heat flux
c      tkocean  :ocean flux coeff [W/m^2K] could be rho(0)*Cp*hmix/dt
c                but is assumed to be constant (typical value ~ 5000 w/m^2K)
c      tfreeze  : freezing temeprature assumed to be fixed (-1.8 C)
	qio=tkocean*(sst-tfreeze)
	
	
c  --- inititalize some variables
        dqf=100.
        iter=0
	
c==  check if ice exist already
	if (hice.gt.hicemin) then
	   
c  --- get old ice temperature
c      hice: represents the 'heat' content in units [Cm]
c      tice: temperature at top of ice sheet.
c      Assuming the ice bottom is at tfreeze, and linear temp. profile
	   
	   tice=2*thice/hice*cice+tfreeze
	   
c  --- qsi is the heat flux at the snow ice interface
	   qsi=(tksnow/hsnow)*(tice-tsnw)
	   
c       qif is the heat flux through the ice
	   qif=(tkice/hice*cice)*(tfreeze-tice)
	   
c       tkice is the ice flux coeff in W/m^2K
	   
c  --- start iteration loop
	   tconv=tconvin
	   do while ((abs(dqf).gt.dqmax).and.(iter.lt.itermax))
	      iter=iter+1
c
c      tconv is convergence factor for the higly nonlinear flux coupling
c
	      tconv=tconv*tconvgr
	      tconv=min(tconv,tconvmax)
c  --- atmos-snow heat flux
c                here we need to know what is done in the atmospheric model
c                and do the same thing each iteration to get the propoer fluxes.
c                First solve for the saturation humidity over ice
	      
	      qsice=0.622*6.11/1000*exp(17.67*(tsnw-273.15)/
     +             (tsnw-273.15+243.5))
	      qsice=qsice*10.**(0.00422*(tsnw-273.15))
	      
c  ---  get current atmos-snow flux
	      qas=aiflux(1)+aiflux(2)*tsnw+aiflux(3)*qsice
	      
c  ---  if divergent try to reduce convergence factor
	      if (abs(dqf).lt.abs(qas-qsi)) then
		 tconv=tconv*0.2 
	      endif
c  ---  get missmatch between atmos-snow and snow-ice flux
	      dqf=qas-qsi
	      
c  --- relax snow-icetop heat flux toward atmos-snow heat flux
	      qsi=qsi+tconv*dqf
	      
c  --- solve for appropriate snow temperature
	      tsnw=tice-qsi*hsnow/tksnow
	      
c  --- if snow temperature is at freezing ignore snow layer
	      if (tsnw-tfreeze.gt.0.5) then
		 dqf=0.
		 tsnw=tfreeze
		 qsice=0.622*6.11/1000*exp(17.67*(tsnw-273.15)/
	1	      (tsnw-273.15+243.5))
		 qsice=qsice*10.**(0.00422*(tsnw-273.15))
		 qas=aiflux(1)+aiflux(2)*tsnw+aiflux(3)*qsice
		 qsi=qas
	      endif
	      
	   enddo
c       end of iteration loop
	   
c
c  change heat content of ice due to conductive fluxes 
c
	   thice=thice-(tstep/(cpice*rhoice))*(qsi-qif)*cice
	   
c
c  check for melting due to conductive fluxes
c
	   if (thice.gt.0) then
	      qmelt=thice * cpice * rhoice / tstep
	      thice=0.
	   else
	      qmelt = 0.
	   endif
	   
	else
c
c  --- when no ice existed do the following
c
	   tsnw=tfreeze
	   if(qio.lt.0) then
	      cice=0.3
	   else
	      cice=0.0
	   endif
	   qsi=0.0
	   qif=0.0
	   tice=0.
	   
	endif
	
c ===== find out how much ice will be grown or melted at this timestep ===
c --- get ice growth/melt at top due to precip and surface melt
	ppi=cice*aiflux(4)*rhowater/rhoice
	dhpdt=ppi-qmelt/(rhoice*hfusionice)
	
c
c      get change in ice thickness at bottom of ice
	dhdt=((qif-qio)*cice)/(rhoice*hfusionice) +dhpdt
	
c      dont melt more ice than existed
	dhdt=max(dhdt,-hice/tstep) 
	dhpdt=max(dhpdt,-hice/tstep)
	
c      save new ice thickness
	hice=hice+dhdt*tstep
	
c --- get (relatively) fresh water flux, 
	brne = -(dhdt-ppi)*rhoice/rhowater*(1-sice/sss)
	
c --- save ice-ocean heat flux qio*cice backed from ice growth
	qios = (dhpdt-dhdt)*rhoice*hfusionice + qif*cice
	
c
c --- no heatcontent for ice thinner than hicemin
c
	if (hice.lt.hicemin) then
	   thice=0.0
	   qif=0.0
	   qsi=0.0
	   qio=0.0
	   tsnw=tfreeze
	endif
	
	
c ======== check if ice has grown or melted and change concentration
c ---  forget about the last millimeter of ice
	if (hice.lt.1.e-3) then
	   hice=0.0
	   cice=0.0
	else
	   
c --- change concentration; dq is the concentration change.
	   if (dhdt.gt.0) then
c --- freezing
	      dq=dhdt*tstep/hq*(1-cice)
	   else
c --- melting
	      dq=dhdt*tstep/(hf*hice)*cice
	   endif
	   
c --- change ice concentration and limit to bounds
	   cice=min(cice+dq,cicemax)
	   cice=max(cice,0.1)
	endif
	
	return
	end
	
c ======================================================================
c     LIST OF VARIABLES:
c     -----------------
c     thice             :ice temp[C m]
c     hice              :ice thickness [m]
c     cice              :ice concentration [0-1]
c     rhoice            :ice density 910 [kg/m^3]
c     tksnow            :snow conductivity 0.33 [W/mK]
c     tkice             :ice conductivity 2.0 [W/mK]
c     hsnow             :snow thickness [m]
c     hicemin           :minimum ice thickness [m]
c     hfusionic         :latent heat of fusion for ice 3.34e5 [J/kg]
c     tfreeze           :freezing temperature -1.8 [C]
c     hq                :convert dh->dq (thickness to extent) freezing 0.25 [m]
c     hf                :convert dh->dq (thickness to extent) melting 2.0
c     cpice             :specific heat 2090 [J/kgK]
c     tkocean           :ocean flux coeff [W/M^2K] could be rho0*cp*hmix/dt
c     tsnw              :snow temperature
c     sice              :ice salinity
c     itermax           :maximum nuber of ice iterations
c     qio               :ice-ocean heat flux. 
c     qif               :icetop-icebottom heat flux. 
c     qsi               :snow-icetop heat flux. 
c     qas               :atmos-snow heat flux. 
c     qios              :net ice-ocean flux (no lead contribution)
c     brne              :net ice-ocean freshwater flux
c ==============================================================================
c
c

       subroutine htfluxi(sst,tice,fice,u,v,wspd,lsm,q,t,cldfr,
     $     sh,rlh,qlw,qa1,th,rh,rlc0ice,cpc0ice,qlwice1,qlwice2,
     $     slat,dxd,dyd,nx,ny,mx,my)


c  This subroutine computes surface fluxes of latent and sensible heat 
c  in units of W/m^2.  The fluxes are computed by a forced advection-
c  diffusion equation.  It solves equations for the virtual potential
c  temperature and the air humidity and then inverts the first to get
c  the air temperature.  In both case the balance is one of diffusion,
c  horizontal advection, surface fluxes and a flux at the mixed layer top.
c  The mixed layer is a constant depth.
c
c  The model also computes long wave cooling with the Berliand and
c  Berliand bulk formula (see Seager and Blumenthal, J. Climate, Dec '94
c  for example).
c
c  Note added 11/7/94:  To date the model has been coupled to an ocean
c  GCM developed by Ragu Murtugudde, now at GSFC.  The results have
c  been good.  Some care is needed at open ocean boundaries it turns out.
c  In the version as I give it here you will see the computation is done
c  only for meridional index j=jstart,jend with jstart=25 and jend =ny-1.
c  This is like putting a boundary in the middle of the southern ocean.
c  For points poleward of the end points the air humidity and temperature
c  are set equal to observed values ensuring that values advected in are
c  realistic.  We used ECMWF data at 1000mb.  We found that the air-sea
c  temperature difference given by this data was too large (probably 
c  'cos the SLP is greater than the lowest ananlysis level of 1000mb) so
c  we correct it to by a dry adiabaltic lapse rate to an slp of 1017 mb
c  which corresponded to a reasonable SLP at 40S which is where our ocean
c  GCM began.  Clearly users are free to do whatever they want but 
c  *be cautious*!.
c
c  The limits are to set jstart =2 and jend=ny-1.  The end points cannot be
c  included because of the diffusion operator that would otherwise look
c  out of array bounds.
c
c  Also, it should be noted that the code is set up for the
c  case of a basin bounded at the east and west.  It hence
c  cannot deal with the part of the Southern Ocean that goes
c  through the Drake passage, or the part of the Arctic north
c  of Greenland.  In both case the matrices would no longer be
c  tridiagonal.  We will change this but we're talking months
c  and months (years?) here. 
c
c  The inputs are:
c
c  All temperatures in K
c
c  sst  = array containing the model or observed SST
c  tice = array containing the model or observed sea ice temperature 
c  fice = array containing the model or observed sea ice fraction
c  u    = array containing observed low level zonal wind velocity
c  v    = array containing observed low level meridional wind velocity
c  wspd = array containing observed low level wind speed
c  lsm  = a land sea mask (1=land, 0= ocean)
c  q    = observed low level air humidity (kg/kg)
c  t    = observed low level temperature (K)
c  cldfr= observed cloud cover
c  slat = southern latitude of input grid, in degrees (e.g. -30.)
c  dxd  = grid spacing in degrees longitude.  dxd(i) equals the distance from
c         the longitude at i-1 to the longitude at i which allows for 
c         uneven grid spacing.
c  dyd  = grid spacing in degrees latitude.  dyd(j) equals the distance from
c         the latitude at j to the latitude at j+1 which allows for 
c         uneven grid spacing.
c  nx   = number of x grid points <= mx 
c  ny   = number of y grid points <= my
c  mx   = x grid dimension
c  my   = y grid dimension
c
c
c  The outputs are:
c
c  sh  = array containing the sensible heat flux for water(W/m^2)
c  rlh = array containing the latent heat flux for water(W/m^2)
c  qa  = atmospheric mixed layer humidity in kg/kg
c  th  = atmospheric mixed layer potential temperature in K
c  qlw = longwave radiative heat flux for water
c  rh  = relative humidity as a fraction
c  rlc0ice = rl*c0ice(i,j)*wspd(i,j)*rhoa
c  cpc0ice = cp*c0ice(i,j)*wspd(i,j)*rhoa
c  qlwice1 = factors*th(i,j)**4
c  qlwice2 = factors*th(i,j)**3
c
c  All fluxes are for the ocean fraction only.  An ice model will
c  calculate the fluxes over sea ice using the air temperature and
c  air humidity derived here.
c
c  The longwave flux over ice can be got from:
c
c  qlwice=qlwice1+qlwice2*(tice-th(i,j))
c
c  Parameters are:
c
c  pnu=diffusivity (m^2/s)
c  delta - equilibrium q = q0/(1+delta) where q0 is saturation humidity
c          at the SST
c  pml=pressure depth (Pa) of the mixed layer
c  depth=geometric depth of mixed layer = (pml/(rhoa*grav)
c  qrad=radiative cooling K/s
c  betav=ratio of downward theta_V flux at mixed layer top to the
c        surface flux
c  c0=surface exchange coefficient
c  constants: rl=latent heat of water.  rlice . . . ice
c             cp = specific heat of water at constant pressure
c             r=univ. gas constant, stef=stefan bolz.'s const.
 

      implicit real*4(a-h,o-z),integer(i-n)

c    make sure parameter nxx, nyx are bigger or equal to mx,my
c      parameter (nxx=??,nyx=??)
      parameter (nxx=800,nyx=800)


      dimension sst(mx,my),u(mx,my),v(mx,my),wspd(mx,my),q(mx,my),
     $     t(mx,my),rlh(mx,my),sh(mx,my),lsm(mx,my),qa1(mx,my),
     $     th(mx,my),qlw(mx,my),cldfr(mx,my),dyd(my),
     $     dxd(mx,my),rh(mx,my),tice(mx,my),fice(mx,my),
     $     rlc0ice(mx,my),cpc0ice(mx,my),qlwice1(mx,my),qlwice2(mx,my)

      dimension up(nxx,nyx),vp(nxx,nyx),thv(nxx,nyx),
     $     thve(nxx,nyx),qs(nxx,nyx),dy(nyx),
     $     thvs(nxx,nyx),pnuxp(nxx,nyx),
     $     pnuyp(nxx,nyx),c0(nxx,nyx),qe(nxx,nyx),
     $     dx(nxx,nyx),qa(nxx,nyx),
     $     c0thv(nxx,nyx),c0q(nxx,nyx),qsice(nxx,nyx),
     $     c00(nxx,nyx),c0ice(nxx,nyx),thvst(nxx,nyx)

      integer idim(2)
      logical advec

      if(nxx.lt.nx .or. nyx.lt.ny) then
       write(*,*) 'arrays in subroutine htfluxi are dimensioned less
     $        than ny and nx set in calling routine'
       write(*,*) 'nxx,nx=',nxx,nx
       write(*,*) 'nyx,ny=',nyx,ny
       stop
      endif

c  advec=.true. implements advection

      advec=.true.

      jstart=2
      jend=ny-1

c  set model parameters

      pnu=0.4e+7
      delta=.25
      pml=6000.
      depth=600.
      betav=0.17
      qrad=-2./86400.

c  set constants

      r=287.04
      psfc=100000.
      rl=2.5e+6
      rlice=2.834e+6
      cp=1004.
      rhoa=1.225
      stef=5.6696e-8
      eps=0.97


      idim(1)=nx
      idim(2)=ny

c  determine grid spacing in m

      conv=2.*3.14/360.
      radius=6.37e+6
      dy(1)=radius*dyd(1)*conv
      rlat=slat*conv
      do 1 i=1,nx
      dx(i,1)=conv*radius*cos(rlat)*dxd(i,1)
 1    continue
      do 2 j=2,ny
      dy(j)=conv*radius*dyd(j)
      rlat=rlat+dyd(j)*conv
      do 2 i=1,nx
      dx(i,j)=conv*radius*cos(rlat)*dxd(i,j)
 2    continue


c  Two iterations are performed.  A smaller exchange coefficient is
c  used on second iteration if mixed layer is stable.
c  First find equilibrium values of theta_V and q.  These are set to
c  their observed values over land.

      fac=.622*6.11/1000.
      do 24 j=1,ny
      do 24 i=1,nx
      c00(i,j)=0.0014
      c0ice(i,j)=0.0028
      if(lsm(i,j) .eq. 0) then
       qs(i,j)=fac*exp(17.67*(sst(i,j)-
     $     273.15)/(sst(i,j)-273.15+243.5))
       if(fice(i,j).gt.0.) then
         qsice1=fac*exp(17.67*(tice(i,j)-
     $     273.15)/(tice(i,j)-273.15+243.5))
         qsice(i,j)=qsice1*10.**(0.00422*(tice(i,j)-273.15))
       endif
      endif
 24   continue
     

      pfac=psfc/(psfc-.5*pml)
      iter=1
      itermx=3
  99  do 25 j=1,ny  
      do 25 i=1,nx
      if(iter.gt.1 .and. (thv(i,j).gt.thvst(i,j))) then
        c00(i,j)=.00075
      endif
      if(lsm(i,j).eq.1) then
         thve(i,j)=t(i,j)*(1.+.61*q(i,j))
         qe(i,j)=q(i,j)
         th(i,j)=t(i,j)
         qa1(i,j)=q(i,j)
        else
         w0=wspd(i,j)*pml/depth
         thvs(i,j)=sst(i,j)*(1.+.61*qs(i,j))
         if(fice(i,j).eq.0.) then
           thve(i,j)=thvs(i,j)+pml*qrad/((1.+betav)*c00(i,j)*w0)
           qe(i,j)=qs(i,j)/(1.+delta)
           thvst(i,j)=thvs(i,j)
          else
           thvice=tice(i,j)*(1.+.61*qsice(i,j))
           c0thv(i,j)=fice(i,j)*c0ice(i,j)+
     $          (1.-fice(i,j))*c00(i,j)
           c0q(i,j)=fice(i,j)*c0ice(i,j)+
     $          (1.-fice(i,j))*c00(i,j)
           thvst(i,j)=(fice(i,j)*c0ice(i,j)*thvice+
     $          (1.-fice(i,j))*c00(i,j)*thvs(i,j))/c0thv(i,j)
           qst=(fice(i,j)*c0ice(i,j)*qsice(i,j)+
     $          (1.-fice(i,j))*c00(i,j)*qs(i,j))/c0q(i,j)
           thve(i,j)=thvst(i,j)+pml*qrad/((1.+betav)*c0thv(i,j)*w0)
           qe(i,j)=qst/(1.+delta)
          endif
      endif
 25   continue

c  Set equilibrium values to observed at northernmost and southernmost
c  points if they are open ocean.  This is required because 
c  advection/diffusion cannot be computed
c  when there is no poleward point.  Actual values of air temperature and
c  air humidity are also set equal to observed values and used in flux
c  calculation.
c  ttoth is a conversion from observed 1000mb temperature to surface
c  temperature using a dry adiabat.  This is here 'cos my input data
c  was for 1000mb temperature not surface temperature and 'cos the
c  observed SLP beyond the extremes of the grid was greater than 
c  1000mb.  You can do what you want but be careful!

      ttoth=(1017./(1000.))**(r/cp)
      do 26 i=1,nx
      do 27 j=1,jstart-1

      if(lsm(i,j).eq.0) then

       up(i,j)=0.
       vp(i,j)=0.
       pnuxp(i,j)=0.
       pnuyp(i,j)=0.
       qe(i,j)=q(i,j)
       thve(i,j)=t(i,j)*ttoth*(1.+.61*q(i,j))
       qa(i,j)=q(i,j)
       thv(i,j)=thve(i,j)
       th(i,j)=t(i,j)*ttoth

      endif

 27   continue

      do 26 j=jend+1,ny

      if(lsm(i,j).eq.0) then

       up(i,j)=0.
       vp(i,j)=0.
       pnuxp(i,j)=0.
       pnuyp(i,j)=0.
       qe(i,j)=q(i,j)
       thve(i,j)=t(i,j)*ttoth*(1.+.61*q(i,j))
       qa(i,j)=q(i,j)
       thv(i,j)=thve(i,j)
       th(i,j)=t(i,j)*ttoth

      endif

 26   continue
      

c  Set diffusion and advecting wind speed.  Over land both are
c  set to zero to ensure derived theta_V and q are observed 
c  values.  In addition, diffusion is set to zero close to 
c  coastline.  

      do 29 j=jstart,jend
      do 29 i=1,nx
      w0=wspd(i,j)*pml/depth
      if(lsm(i,j).eq.1) then 
        up(i,j)=0.
        vp(i,j)=0.
        pnuxp(i,j)=0.
        pnuyp(i,j)=0.
       else
        if(fice(i,j).eq.0.) then
          c0(i,j)=c00(i,j)
         else
          c0(i,j)=c0thv(i,j)
        endif
        ip1=i+1
        if(ip1.eq.(nx+1)) ip1=nx
        ip2=i+2
        if(ip2.eq.(nx+2) .or. ip2.eq.(nx+1)) ip2=nx
        im1=i-1
        if(im1.eq.0) im1=1
        im2=i-2
        if(im2.eq.0 .or. im2.eq.-1) im2=1
        jm1=j-1
        jm2=j-2
        if(jm2.eq.0) jm2=1
        jp1=j+1
        jp2=j+2
        if(jp2.eq.(ny+1)) jp2=ny 
        if(lsm(ip1,j).eq.1 .or. lsm(im1,j).eq.1
     $   .or. lsm(i,jp1).eq.1 .or. lsm(i,jm1).eq.1 
     $   .or. lsm(ip2,j).eq.1 .or. lsm(im2,j).eq.1
     $   .or. lsm(i,jp2).eq.1 .or. lsm(i,jm2).eq.1  ) then
         pnuxp(i,j)=0.
         pnuyp(i,j)=0.
        else
         if(i.eq.1 .or. i.eq.nx) then
            twodx2=dx(i,j)**2.
           else
            twodx2=.25*(dx(i,j)+dx(i+1,j))**2.
         endif
         pnuxp(i,j)=pnu*pml/((1.+betav)*c0(i,j)*w0*twodx2)
         pnuyp(i,j)=pnu*pml/((1.+betav)*c0(i,j)*w0*.25*(dy(j)+dy(j-1))*
     $        (dy(j)+dy(j-1)))
        endif 
        if(advec) then
         if(u(i,j).gt.0.) then
           i1=i
          else
           i1=i+1
           if(i.eq.nx) i1=nx
         endif
         up(i,j)=u(i,j)*pml/((1.+betav)*c0(i,j)*w0*dx(i1,j))
         if(v(i,j).gt.0.) then
           vp(i,j)=v(i,j)*pml/((1.+betav)*c0(i,j)*w0*dy(j-1))
          else
           vp(i,j)=v(i,j)*pml/((1.+betav)*c0(i,j)*w0*dy(j))
         endif
        else
         up(i,j)=0.
         vp(i,j)=0.
        endif
      endif
 29   continue

c  call subroutine that solves for theta_V

      call adv2Deq1m(idim,nxx,nyx,up,vp,pnuxp,pnuyp,thve,thv)


c  repeat one time

      iter=iter+1

      if(iter.lt.itermx) goto 99

c  set scaled advecting velocities for humidity calculation and
c  impose no diffusion across continental boundaries


      do 39 j=jstart,jend
      do 39 i=1,nx
      w0=wspd(i,j)*pml/depth
      if(lsm(i,j).eq.0) then 
        if(fice(i,j).eq.0.) then
          c0(i,j)=c00(i,j)
         else
          c0(i,j)=c0q(i,j)
        endif
        ip1=i+1
        if(ip1.eq.(nx+1)) ip1=nx
        ip2=i+2
        if(ip2.eq.(nx+2) .or. ip2.eq.(nx+1)) ip2=nx
        im1=i-1
        if(im1.eq.0) im1=1
        im2=i-2
        if(im2.eq.0 .or. im2.eq.-1) im2=1
        jm1=j-1
        jm2=j-2
        if(jm2.eq.0) jm2=1
        jp1=j+1
        jp2=j+2
        if(jp2.eq.(ny+1)) jp2=ny 
        if(lsm(ip1,j).eq.1 .or. lsm(im1,j).eq.1
     $   .or. lsm(i,jp1).eq.1 .or. lsm(i,jm1).eq.1  
     $   .or. lsm(ip2,j).eq.1 .or. lsm(im2,j).eq.1
     $   .or. lsm(i,jp2).eq.1 .or. lsm(i,jm2).eq.1  ) then
         pnuxp(i,j)=0.
         pnuyp(i,j)=0.
        else
         if(i.eq.1 .or. i.eq.nx) then
            twodx2=dx(i,j)**2.
           else
            twodx2=.25*(dx(i,j)+dx(i+1,j))**2.
         endif
         pnuxp(i,j)=pnu*pml/((1.+delta)*c0(i,j)*w0*twodx2)
         pnuyp(i,j)=pnu*pml/((1.+delta)*c0(i,j)*w0*.25*(dy(j)+dy(j-1))*
     $        (dy(j)+dy(j-1)))
        endif
        if(advec) then
         if(u(i,j).gt.0.) then
           i1=i
          else
           i1=i+1
           if(i.eq.nx) i1=nx
         endif
         up(i,j)=u(i,j)*pml/((1.+delta)*c0(i,j)*w0*dx(i1,j))
         if(v(i,j).gt.0.) then
           vp(i,j)=v(i,j)*pml/((1.+delta)*c0(i,j)*w0*dy(j-1))
          else
           vp(i,j)=v(i,j)*pml/((1.+delta)*c0(i,j)*w0*dy(j))
         endif
        else
         up(i,j)=0.
         vp(i,j)=0.
        endif
      endif
 39   continue

c  call solver to derive q 
      call adv2Deq1m(idim,nxx,nyx,up,vp,pnuxp,pnuyp,qe,qa)

c  calculate theta from theta_V and q
c  calculate fluxes of sensible and latent heat

      do 30 j=1,ny
      do 30 i=1,nx

      if(lsm(i,j).eq. 0) then

        rlh(i,j)=rhoa*rl*c00(i,j)*wspd(i,j)*(qs(i,j)-qa(i,j))
        th(i,j)=thv(i,j)/(1.+.61*qa(i,j))
        sh(i,j)=rhoa*cp*c00(i,j)*wspd(i,j)*(sst(i,j)-th(i,j))
        qlw(i,j)=eps*stef*(th(i,j)**4.)*(.39-.05*
     $       sqrt(abs(qa(i,j))*1000./.622))
     $       *(1.-.55*cldfr(i,j)) + 4.*eps*stef*
     $       (th(i,j)**3.)*(sst(i,j)-th(i,j))
        rlc0ice(i,j)=rhoa*rlice*c0ice(i,j)*wspd(i,j)
        cpc0ice(i,j)=rhoa*cp*c0ice(i,j)*wspd(i,j)
        qlwice1(i,j)=eps*stef*(th(i,j)**4.)*(.39-.05*
     $       sqrt(abs(qa(i,j))*1000./.622))
     $       *(1.-.55*cldfr(i,j))
        qlwice2(i,j)=4.*eps*stef*(th(i,j)**3.)
        qa1(i,j)=qa(i,j)

      endif
      qsatair=fac*exp(17.67*(th(i,j)-273.15)/(th(i,j)-273.15+243.5))
      rh(i,j)=qa(i,j)/qsatair		!relative humidity

 30   continue

      return
      end
c==============================================================================
c
      SUBROUTINE adv2Deq1m(IDIM,NX,NY,UP,VP,NUXP,NUYP,QE,QA)
 
 
      REAL UP(NX,NY),VP(NX,NY), QE(NX,NY)
      REAL NUXP(NX,NY),NUYP(NX,NY)
      REAL  QA(NX,NY)
      INTEGER IDIM(2)
 
C       variables are dimensioned with X first
      MX = IDIM(1)
      MY = IDIM(2)
      NXSKP = 1
      NYSKP = NX
 
C       does X advection
C       loops over all latitudes
      IX = 1
      DO IY = 1 , MY
         CALL ADVDIFQ1DX(UP(1,IY),NUXP(1,IY),MX,QE(1,IY),QE(1,IY),
     *        QE(MX,IY),QA(1,IY))
 
      END DO
C       does Y advection
C       loops over all longitudes
      IY = 1
      DO IX = 1 , MX
C               boundary conditions
         QLEFT = QE(IX,1)
         QRIGHT = QE(IX,MY)
         CALL ADVDIFQ1D(VP(IX,1),NUYP(IX,1),MY,QA(IX,1),
     *        QLEFT,QRIGHT,NYSKP,QA(IX,1))
      END DO
 
      RETURN
      END


dyn_baro.f/     842887265   1572  1572  100444  9786      `
c$Source$
c$Author$
c$Revision$
c$Date$
c$State$
c---------------------------------------------------------
      subroutine baro_sum (npt, nz, nzi_b, uc, vc, ubar, vbar)
c---------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension uc(npt,nz),vc(npt,nz), ubar(npt), vbar(npt), nzi_b(npt)

      do i = 1, npt
         ubar(i) = uc(i,1)
         vbar(i) = vc(i,1)
      enddo
      
      do i = 1, npt
         do k = 2, nzi_b(i)
            ubar(i) = ubar(i) + uc(i,k)
            vbar(i) = vbar(i) + vc(i,k)
         enddo
      enddo

      return
      end

      subroutine baro_scale (npt, ubar, vbar, dept)
c---------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension ubar(1), vbar(1), dept(1)

      do i = 1, npt
         depi = 1./dept(i)
         ubar(i) = depi* ubar(i)
         vbar(i) = depi* vbar(i)
      enddo
      
      return
      end

      subroutine baro_tau (npt, uforc, vforc, taux, tauy)
c---------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension uforc(npt), vforc(npt), taux(npt), tauy(npt)
      include 'comm_new.h'

      do i = 1, npt
         uforc(i) = taux(i)
         vforc(i) = tauy(i)
      enddo

      return
      end

      subroutine baro_comp (npt,dnt,abi,bi,nbaro,uforc,vforc,tfu,tfv
     *             ,zfu,zfv,dept)
c-----------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension uforc(npt),vforc(npt),tfu(npt),tfv(npt),zfu(npt),zfv(npt),dept(npt)

      b_d2 = bi / (dnt * real(nbaro))
      do i = 1, npt
         depi = dept(i)
         dzu = zfu(i) - depi* tfu(i)
         dzv = zfv(i) - depi* tfv(i)
         uforc(i) = uforc(i) - b_d2*dzu
         vforc(i) = vforc(i) - b_d2*dzv
         zfu(i) = abi * dzu
         zfv(i) = abi * dzv
      enddo
      return
      end

      subroutine baro_rhs (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk,
     *     isyk,isk,mbc,lpbcwk,lpbcek,uu,vv,rhs,tp,dept)
c------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz)

      dimension emx(1),emy(1),emxy(1),dept(npt),uu(npt),vv(npt),rhs(npt),
     *          tp(npt,3)

      do i = 1, npt
         depi = 1./dept(i)
         tp(i,3) = depi* uu(i)
         tp(i,2) = depi* vv(i)
      enddo

      nxk = nbxk(1)
      nyk = nbyk(1)
      nck = ncsk(1)
      npbk = npbck(1)
      nbu = 0
      nbv = 0

      call dfdx1(tp(1,2),tp,npt,nbu,nxk,nyk,nck,lxxk,lyxk,
     *     snxk,npbk,lpbcwk,lpbcek)
      call dfdy1(tp(1,3),tp(1,2),npt,nbv,nyk,nxk,nck,
     *     lyyk,lxyk,snyk,isyk)

c.................rhs = -curl(forcing/depth)
      if (mgrid .ne. 2) then
         do i = 1, npt
            rhs(i) = emx(i)*tp(i,1) - emy(i)*tp(i,2)
         enddo
      else
         do i = 1, npt
            rhs(i) = emx(i)*tp(i,1) - emy(i)*tp(i,2) - emxy(i)*tp(i,3)
         enddo
      endif

      return
      end

      subroutine curl_of_psi (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk,
     *     isyk,isk,mbc,lpbcwk,lpbcek,psi,sfu,sfv,tp,dept)
c------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz)

      dimension emx(npt),emy(npt),emxy(npt),dept(npt),
     *          sfu(npt),sfv(npt),psi(npt),tp(npt,2)
      
      k = 1
      nxk = nbxk(k)
      nyk = nbyk(k)
      nck = ncsk(k)
      npbk = npbck(k)
      nbu = 0
      nbv = 0
      
      call dfdy1(psi,tp(1,2),npt,nbv,nyk,nxk,nck,lyyk,lxyk,snyk,isyk)
      call dfdx1(psi,tp,npt,nbu,nxk,nyk,nck,lxxk,lyxk,
     *     snxk,npbk,lpbcwk,lpbcek)

      do i = 1, npt
         depi = 1./dept(i)
         sfu(i) = -emy(i)*tp(i,2)*depi
         sfv(i) =  emx(i)*tp(i,1)*depi
      enddo
      return
      end

      subroutine baro_updat(npt,nz,nzi,h,uc,vc,tfu,tfv,uforc,vforc,ubar,vbar)
c------------------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension h(npt,nz),uc(npt,nz),vc(npt,nz),
     *     tfu(npt),tfv(npt), 
     *     uforc(npt), vforc(npt), ubar(npt), vbar(npt), nzi(npt)

      do i = 1, npt
         do k = 1, nzi(i)
            hik = h(i,k)
            uc(i,k) = uc(i,k) + hik*(tfu(i) - ubar(i))
            vc(i,k) = vc(i,k) + hik*(tfv(i) - vbar(i))
         enddo
      enddo
      do i = 1, npt
         uforc(i) = 0.
         vforc(i) = 0.
         ubar(i) = tfu(i)
         vbar(i) = tfv(i)
      enddo

      return
      end

      subroutine baro_div (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,
     *           snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,ubar,vbar,bdiv,tp,dept)
c------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz)

      dimension emx(1),emy(1),emxy(1),dept(1),
     *          ubar(1),vbar(1),bdiv(1),tp(npt,1)
      
      nbu = 0
      nbv = 0
      if(mbc.eq.1 .or. mbc.eq.4) nbu = 1
      if(mbc.eq.1 .or. mbc.eq.3) nbv = 1
 
      do i = 1, npt
         depi = dept(i)
         tp(i,3) = depi* ubar(i)
         tp(i,4) = depi* vbar(i)
      enddo
      
      nxk = nbxk(1)
      nyk = nbyk(1)
      nck = ncsk(1)
      npbk = npbck(1)
      
      call dfdy1(tp(1,4),tp(1,2),npt,nbv,nyk,nxk,nck,lyyk,lxyk,snyk,isyk)
      call dfdx1(tp(1,3),tp,npt,nbu,nxk,nyk,nck,lxxk,lyxk,
     *     snxk,npbk,lpbcwk,lpbcek)

      if (mgrid .ne. 2) then
         do i = 1, npt
            depi = 1./dept(i)
            bdiv(i) = depi*(emx(i)*tp(i,1) + emy(i)*tp(i,2))
         enddo
      else
         do i = 1, npt
            depi = 1./dept(i)
            bdiv(i) = depi*(emx(i)*tp(i,1) + emy(i)*tp(i,2) + emxy(i)*tp(i,4))
         enddo
      endif

      return
      end
      
c     ------------------------------------------------------------------
      subroutine baro_bcset(mbc,lxxk,lyyk,npt,u,v)
c     ------------------------------------------------------------------
c     impose the u, v boundary conditions according to mbc.
c
c     mbc = (input) type of boundary condition:
c         = 1; u(xb)=v(yb)=u(yb)    = v(xb)    = 0; no slip everywhere.
c         = 2; u(xb)=v(yb)                     = 0; no normal flow.
c         = 3; u(xb)=v(yb)=du(yb)/dy= v(xb)    = 0; no slip at eastern
c              and western side walls; free slip along northern and
c              southern boundaries/steps, v=du/dy=0.
c         = 4; u(xb)=v(yb)=u(yb)    = dv(xb)/dx= 0; no slip at northern
c              and southern; free slip along eastern and western
c              boundaries/steps, u=dv/dy=0.
c
c     lxx = (input) nbx x-boundary plus ncs corner indices for a 
c           regular or compressed x-sort.
c     lyy = (input) nby y-boundary plus ncs corner indices for a
c           regular or compressed x-sort.
c     npt = (input) number of field points/layer.
c     u,v = (input) fields.
c         = (output) fields with boundary conditions imposed.
c
      implicit real(a-h,o-z),integer(i-n)

      include 'comm_para.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc

      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension lxxk(MXBDY,nz), lyyk(MXBDY,nz)

      dimension u(npt),v(npt)
c
c     normal components are always zero at boundaries, u(xb)=v(yb)=0.
c     similarly, so is the along boundary derivative
c       du(xb)/dy = dv(yb)/dx = 0.
c
c     the ncs corner points are part of the u/v-boundaries depending
c     on mbc.
c     mbc = 1;  yes for u and v;     du(yb)/dx = dv(xb)/dy = 0.
c         = 2;  no for u and v.
c         = 3;  no for u, yes for v; dv(xb)/dy = 0.
c         = 4;  yes for u, no for v; du(yb)/dx = 0.
c
      k = 1
         do i = 1, nbxk(k)
            u(lxxk(i,k)) = 0.
         enddo
         do i = 1, nbyk(k)
            v(lyyk(i,k)) = 0.
         enddo

      if(mbc.eq.1 .or. mbc.eq.4) then
         do 30 i=1,nbyk(k)+ncsk(k)
   30    u(lyyk(i,k)) = 0.
      endif
c
      if(mbc.eq.1 .or. mbc.eq.3) then
         do 40 i=1,nbxk(k)+ncsk(k)
   40    v(lxxk(i,k)) = 0.
      endif

      return
c     end of baro_bcset.
      end

dyn_dens.f/     848938479   1572  1572  100444  40523     `
      function dens_unesco (temp, sal, pres)
c--------------------------------------------
      real*8 rh, rh0

ccccccccccccccccccccccccccccccccccccccccccccccc
c Gilles's variant:
c     situ = theta (pres, temp, sal, 0.)
c then, for insitu dens (for poten. dens pres = 0.):
c     call dens_eos (pres, situ, sal, rh0, rh)
c     dens_unesco = 1.e3 * real(rh - 1.d0) 
c
c "sigth" variant:       
c      call dens_eos (pres, thet, sal, rh0, rh)
c      dens_unesco = 1.e3 * real(rh0 - 1.d0) 
ccccccccccccccccccccccccccccccccccccccccccccccc

      call dens_eos (pres, temp, sal, rh0, rh)
      dens_unesco = 1.e3 * real(rh - 1.d0) 
      
      return
      end

      function sdens_pnt (temp, sal, pres)
c-------------------------------------------------
      include 'comm_para.h'
      include 'comm_new.h'

      if     (isalt .eq. 1) then
         sdens_pnt = SIGMA0 - TCOEF * (temp - TEMP_BOT) 
      elseif (isalt .eq. 2) then
         sdens_pnt = pdens1 (temp)
      elseif (isalt .eq. 3) then
         sdens_pnt = pdens4 (temp, sal, pres)
      elseif (isalt .eq. 4) then
         sdens_pnt = pdens12 (temp, sal, pres)
      elseif (isalt .eq. 5) then
         sdens_pnt = pdens17 (temp, sal, pres)
      elseif (isalt .eq. 6) then
         situ = theta_eos (pres, temp, sal, 0.) 
         sdens_pnt = dens_unesco (situ, sal, pres)
      endif

      return
      end

      function pdens_pnt (thet, sal)
c-------------------------------------------------
      include 'comm_para.h'
      include 'comm_new.h'

      if     (isalt .eq. 1) then
         pdens_pnt = SIGMA0 - TCOEF * (thet - TEMP_BOT) 
      elseif (isalt .eq. 2) then
         pdens_pnt = pdens1 (thet)
      elseif (isalt .eq. 3) then
         pdens_pnt = pdens4 (thet, sal, 0.)
      elseif (isalt .eq. 4) then
         pdens_pnt = pdens012 (thet, sal)
      elseif (isalt .eq. 5) then
         pdens_pnt = pdens017 (thet, sal)
      elseif (isalt .eq. 6) then
         pdens_pnt = dens_unesco (thet, sal, 0.)
      endif

      return
      end

c-----------------------------------------------------
      subroutine dens_init (npt, nz, nzi, t, sal, dens, h) 
c-----------------------------------------------------
csenq
      dimension t(npt,1), sal(npt,1), dens(npt,1), nzi(1), h(npt,1)
      include 'comm_new.h'

c
      do i = 1, npt
         do k = 1, nzi(i)
            POTND_BOT = amax1(POTND_BOT,pdens_pnt (t(i,k),sal(i,k)))
         enddo
      enddo
      POTND_BOT = amax1(POTND_BOT,pdens_pnt (TEMP_BOT, SALT_BOT))

      call situ_dens (npt, nz, nzi, t, sal, dens, h) 

      SITUD_BOT = POTND_BOT
      do i = 1, npt
         do k = 1, nzi(i)
            SITUD_BOT = amax1(SITUD_BOT,dens(i,k))
         enddo
      enddo
      SITUD_BOT = amax1(SITUD_BOT,sdens_pnt (TEMP_BOT, SALT_BOT, dep_max))

      write (iout, *) 'TEMP_BOT   = ', TEMP_BOT
      write (iout, *) 'SALT_BOT   = ', SALT_BOT
      write (iout, *) 'MAX_DEPTH  = ', dep_max
      write (iout, *) 'DENS_BOT(in situ)    = ', SITUD_BOT
      write (iout, *) 'DENS_BOT(potential)  = ', POTND_BOT

      return
      end

c----------------------------------------------------------------
      subroutine situ_dens (npt, nz, nzi, tem, sal, dens, h)
c----------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'
      dimension tem(npt,nz), sal(npt,nz), dens(npt,nz), h(npt,nz), nzi(npt)
c in situ SIGMA density as a function of potential temperature, 
c salinity & pressure. sigma == 1000. * (rho - 1.); 
c Senya Basin 1992
c
      if     (isalt .eq. 1) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = SIGMA0 - TCOEF * (tem(i,k) - TEMP_BOT) 
            enddo
         enddo
      elseif (isalt .eq. 2) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = pdens1 (tem(i,k))
            enddo
         enddo
      elseif (isalt .eq. 3) then
         do i = 1, npt
            pp  = h(i,1)/2.
            pp1 =  pp
            pp0 = -pp
            do k = 1, nzi(i)
               dens(i,k) = pdens4 (tem(i,k), sal(i,k), pp) 
               pp = pp0 + 2.*h(i,k)
               pp0 = pp1
               pp1 = pp
            enddo
         enddo
      elseif (isalt .eq. 4) then
         do i = 1, npt
            pp  = h(i,1)/2.
            pp1 =  pp
            pp0 = -pp
            do k = 1, nzi(i)
               dens(i,k) = pdens12 (tem(i,k), sal(i,k), pp) 
               pp = pp0 + 2.*h(i,k)
               pp0 = pp1
               pp1 = pp
            enddo
         enddo
      elseif (isalt .eq. 5) then
         do i = 1, npt
            pp  = h(i,1)/2.
            pp1 =  pp
            pp0 = -pp
            do k = 1, nzi(i)
               dens(i,k) = pdens17 (tem(i,k), sal(i,k), pp) 
               pp = pp0 + 2.*h(i,k)
               pp0 = pp1
               pp1 = pp
            enddo
         enddo
      elseif (isalt .eq. 6) then
         do i = 1, npt
            pp  = h(i,1)/2.
            pp1 =  pp
            pp0 = -pp
            do k = 1, nzi(i)
               salt = sal(i,k)
c Gilles variant:
               situ = theta_eos (pp, tem(i,k), salt, 0.)
               dens(i,k) = dens_unesco (situ, salt, pp)
               pp = pp0 + 2.*h(i,k)
               pp0 = pp1
               pp1 = pp
            enddo
         enddo
      endif

      return
      end

c----------------------------------------------------------------
      subroutine potn_dens (npt, nzi, tem, sal, dens)
c----------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'
      dimension tem(npt,1), sal(npt,1), dens(npt,1), nzi(1)
c Potential SIGMA density as a function of potential temperature & salinity
c sigma == 1000. * (rho - 1.); 
c Senya Basin 1992
c
      if     (isalt .eq. 1) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = SIGMA0 - TCOEF * (tem(i,k) - TEMP_BOT) 
            enddo
         enddo
      elseif (isalt .eq. 2) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = pdens1 (tem(i,k))
            enddo
         enddo
      elseif (isalt .eq. 3) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = pdens4 (tem(i,k), sal(i,k), 0.) 
            enddo
         enddo
      elseif (isalt .eq. 4) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = pdens012 (tem(i,k), sal(i,k)) 
            enddo
         enddo
      elseif (isalt .eq. 5) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = pdens017 (tem(i,k), sal(i,k)) 
            enddo
         enddo
      elseif (isalt .eq. 6) then
         do i = 1, npt
            do k = 1, nzi(i)
               dens(i,k) = dens_unesco (tem(i,k), sal(i,k), 0.)
            enddo
         enddo
      endif

      return
      end

c------------------------------------------------------------------------------
      subroutine dconv (npt,nz,nzi,u,v,uc,vc,h,t,sal,dens,tr,convn)
c------------------------------------------------------------------------------
c main aim: removing possible static instability in density.
c           No influence on layer depths in this version
c          (see isopycnal mixing model in Ragu's version)
c-----------------------------------------------------------------Senq Ltd. Co.
c
c      boundary condition at bottom changed - instead of t(i,nzi) = t_bot
c      i prefer t(i,nzi)_after = t(i,nzi)_before - NHN

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      common /errors/ ioerr, nstep
c
      dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), 
     *        t(npt,nz), sal(npt,nz), dens(npt,nz), convn(npt,nz), nzi(npt),
     *        tr(npt,nz,1)

      parameter (ERR_LEV = 1.e-4)
c
      if (.not. use_salt) then
         call tconv (npt,nz,nzi,u,v,uc,vc,h,t,tr,convn)
         return
      endif

      do i = 1, npt
         do k = 1, nzi(i) - 1
            kp = k + 1

            if (dens(i,k)-dens(i,kp) .gt. ERR_LEV) then

               hinv = h(i,k) + h(i,kp)
               oldpotener = (dens(i,kp)*h(i,kp) + dens(i,k)*hinv)/2.

               hinv = 1.0 / hinv
               hki  = hinv * h(i,k)
               hkpi = hinv * h(i,kp)

               tmp = uc(i,k) + uc(i,kp)
               uc(i,k)  = tmp * hki
               uc(i,kp) = tmp * hkpi
               tmp = hinv * tmp
               u(i,k)  = tmp 
               u(i,kp) = tmp 

               tmp = vc(i,k) + vc(i,kp)
               vc(i,k)  = tmp * hki
               vc(i,kp) = tmp * hkpi
               tmp = hinv * tmp
               v(i,k)  = tmp 
               v(i,kp) = tmp 

               tmp1 = hki*t(i,k) + hkpi*t(i,kp)
               t(i,k)  = tmp1
               t(i,kp) = tmp1

               tmp = hki*sal(i,k) + hkpi*sal(i,kp)
               sal(i,k)  = tmp
               sal(i,kp) = tmp

               tmp = pdens_pnt (tmp1, tmp) 
               dens(i,k)  = tmp
               dens(i,kp) = tmp

               do m = 1, ntrac
                  tmp = hki*tr(i,k,m) + hkpi*tr(i,kp,m)
                  tr(i,k,m)  = tmp
                  tr(i,kp,m) = tmp
               enddo

               znewpotener = dens(i,k)*(h(i,kp) + h(i,k)/2.)
               convn(i,k) = convn(i,k) + oldpotener - znewpotener
            endif
         enddo
      enddo

      return
      end

c------------------------------------------------------------------------------
      subroutine tconv (npt,nz,nzi,u,v,uc,vc,h,t,tr,convn)
c------------------------------------------------------------------------------
c main aim: removing possible static instability in density.
c           No influence on layer depths in this version
c          (see isopycnal mixing model in Ragu's version)
c-----------------------------------------------------------------Senq Ltd. Co.
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'
      common /errors/ ioerr, nstep
c
      dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), 
     *          t(npt,nz), convn(npt,nz), nzi(npt), tr(npt,nz,1)

      parameter (ERR_LEV = 1.e-4)
c

      do i = 1, npt
         do k = 1, nzi(i) - 1
            kp = k + 1
            if (t(i,kp)-t(i,k) .gt. ERR_LEV) then
               convn(i,k) = convn(i,k) + t(i,kp)-t(i,k)
               hinv = 1.0 / (h(i,k) + h(i,kp))
               hki  = hinv * h(i,k)
               hkpi = hinv * h(i,kp)

               tmp = uc(i,k) + uc(i,kp)
               uc(i,k)  = tmp * hki
               uc(i,kp) = tmp * hkpi
               tmp = hinv * tmp
               u(i,k)  = tmp 
               u(i,kp) = tmp 

               tmp = vc(i,k) + vc(i,kp)
               vc(i,k)  = tmp * hki
               vc(i,kp) = tmp * hkpi
               tmp = hinv * tmp
               v(i,k)  = tmp 
               v(i,kp) = tmp 

               tmp = hki*t(i,k) + hkpi*t(i,kp)
               t(i,k)  = tmp
               t(i,kp) = tmp

               do m = 1, ntrac
                  tmp = hki*tr(i,k,m) + hkpi*tr(i,kp,m)
                  tr(i,k,m)  = tmp
                  tr(i,kp,m) = tmp
               enddo
            endif
         enddo
      enddo

      return
      end


c------------------------------------------------------------------------------
      subroutine dconv_cl (npt,nz,nzi,h,t,sal,dens)
c------------------------------------------------------------------------------
c main aim: removing possible static instability in density.
c           No influence on layer depths in this version
c          (see isopycnal mixing model in Ragu's version)
c-----------------------------------------------------------------Senq Ltd. Co.
c
c      boundary condition at bottom changed - instead of t(i,nzi) = t_bot
c      i prefer t(i,nzi)_after = t(i,nzi)_before - NHN

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      common /errors/ ioerr, nstep
c
      dimension h(npt,nz), 
     *        t(npt,nz), sal(npt,nz), dens(npt,nz), nzi(npt)

      parameter (ERR_LEV = 1.e-4)
c
      if (.not. use_salt) then
         call tconv_cl (npt,nz,nzi,h,t)
         return
      endif



      do i = 1, npt
         do k = 1, nzi(i) - 1
            kp = k + 1

            if (dens(i,k)-dens(i,kp) .gt. ERR_LEV) then

               hinv = h(i,k) + h(i,kp)
               oldpotener = (dens(i,kp)*h(i,kp) + dens(i,k)*hinv)/2.

               hinv = 1.0 / hinv
               hki  = hinv * h(i,k)
               hkpi = hinv * h(i,kp)

               tmp1 = hki*t(i,k) + hkpi*t(i,kp)
               t(i,k)  = tmp1
               t(i,kp) = tmp1

               tmp = hki*sal(i,k) + hkpi*sal(i,kp)
               sal(i,k)  = tmp
               sal(i,kp) = tmp

               tmp = pdens_pnt (tmp1, tmp) 
               dens(i,k)  = tmp
               dens(i,kp) = tmp

               znewpotener = tmp*(h(i,kp) + h(i,k)/2.)
            endif
         enddo
      enddo

      return
      end

c------------------------------------------------------------------------------
      subroutine tconv_cl (npt,nz,nzi,h,t)
c------------------------------------------------------------------------------
c main aim: removing possible static instability in density.
c           No influence on layer depths in this version
c          (see isopycnal mixing model in Ragu's version)
c-----------------------------------------------------------------Senq Ltd. Co.
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'
      common /errors/ ioerr, nstep
c
      dimension h(npt,nz), t(npt,nz), nzi(npt)

      parameter (ERR_LEV = 1.e-4)
c

      do i = 1, npt
         do k = 1, nzi(i) - 1
            kp = k + 1
            if (t(i,kp)-t(i,k) .gt. ERR_LEV) then
               hinv = 1.0 / (h(i,k) + h(i,kp))
               hki  = hinv * h(i,k)
               hkpi = hinv * h(i,kp)

               tmp = hki*t(i,k) + hkpi*t(i,kp)
               t(i,k)  = tmp
               t(i,kp) = tmp
            endif
         enddo
      enddo

      return
      end

c---------------------------------------------------------------------
      subroutine drich_mix (npt, nz, nzi, h,u,v,uc,vc,tem,sal,dens,tr)
c---------------------------------------------------------------------
c Senya Basin, 1992

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'

      dimension rnu(MAXNZ), rka(MAXNZ)
      dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), 
     *     dens(npt,nz), tem(npt,nz), sal(npt,nz), nzi(npt), tr(npt,nz,1)

      common /errors/ ioerr, nstep
      common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ)

      parameter (R_COEF  = -0.5 * GRAVTY/1000.)
      parameter (R_CRIT  = 2.e5)
      parameter (DUZ_0   = 1.e-5)
c
c  Ri = -(g/rho0) * d(rho)/dz / (du/dz**2 + du/dz**2)
c  
      if (.not. use_salt) then
         call trich_mix (npt, nz, nzi, h,u,v,uc,vc,tem,tr)
         return
      endif

      do i = 1, npt
         ndim = nzi(i)
         rnu(ndim) = 0.
         rka(ndim) = 0.

         do k = 1, ndim-1

            uu = u(i,k) - u(i,k+1)
            vv = v(i,k) - v(i,k+1)
            du2 = uu*uu + vv*vv
c            if (du2 .lt. DUZ_0) du2 = DUZ_0
            du2 = du2 + DUZ_0

            h12  = h(i,k) + h(i,k+1)
            rich = R_COEF * h12 * (dens(i,k) - dens(i,k+1)) / du2

            call visc_diff (rich, vnu, vka)
            tmp = DLT_MIX / h12
            rnu(k) = tmp * vnu
            rka(k) = tmp * vka
         enddo

         ixy = i
         call tria_init (npt, rnu, h)
         call tria_tem (npt, u, 0.)
         call tria_tem (npt, v, 0.)
            
         call tria_init (npt, rka, h)
         tb = tem(i,ndim)
         sb = sal(i,ndim)
         call tria_tem (npt, tem, tb)
         call tria_tem (npt, sal, sb)

         do m = 1, ntrac
            trb = tr(i,ndim,m)
            call tria_tem (npt, tr(1,1,m), trb)
         enddo
         
      enddo
         
      do i = 1, npt 
         do k = 1, nzi(i)
            hi = h(i,k)
            uc(i,k) = u(i,k) * hi
            vc(i,k) = v(i,k) * hi
         enddo
      enddo
      
      return
      end

c---------------------------------------------------------------------
      subroutine trich_mix (npt, nz, nzi, h,u,v,uc,vc,tem,tr)
c---------------------------------------------------------------------
c Senya Basin, 1992

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'

      dimension rnu(MAXNZ), rka(MAXNZ)
      dimension u(npt,nz), v(npt,nz), uc(npt,nz), vc(npt,nz), h(npt,nz), 
     *     tem(npt,nz), nzi(npt), tr(npt,nz,1)

      common /errors/ ioerr, nstep
      common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ)

      parameter (R_COEF  = -0.5 * GRAVTY/1000.)
      parameter (R_CRIT  = 2.e5)
      parameter (DUZ_0   = 1.e-5)
c
c  Ri = -(g/rho0) * d(rho)/dz / (du/dz**2 + du/dz**2)
c  
      rtcoef = TCOEF * R_COEF

      do i = 1, npt
         ndim = nzi(i) 
         rnu(ndim) = 0.
         rka(ndim) = 0.

         do k = 1, ndim-1

            uu = u(i,k) - u(i,k+1)
            vv = v(i,k) - v(i,k+1)
            du2 = uu*uu + vv*vv
            if (du2 .lt. DUZ_0) du2 = DUZ_0

            h12  = h(i,k) + h(i,k+1)
c            dik  = TCOEF * (TEMP_BOT - tem(i,k)) 
c            dik1 = TCOEF * (TEMP_BOT - tem(i,k+1)) 
c            rich = R_COEF * h12 * (dik - dik1) / du2
            rich = rtcoef * h12 * (tem(i,k+1) - tem(i,k)) / du2

            call visc_diff (rich, vnu, vka)
            tmp = DLT_MIX / h12
            rnu(k) = tmp * vnu
            rka(k) = tmp * vka
         enddo

         ixy = i
         call tria_init (npt, rnu, h)
         call tria_tem (npt, u, 0.)
         call tria_tem (npt, v, 0.)
            
         call tria_init (npt, rka, h)
         tb = tem(i,ndim)
         call tria_tem (npt, tem, tb)

         do m = 1, ntrac
            trb = tr(i,ndim,m)
            call tria_tem (npt, tr(1,1,m), trb)
         enddo
         
      enddo
         
      do i = 1, npt 
         do k = 1, nzi(i)
            hi = h(i,k)
            uc(i,k) = u(i,k) * hi
            vc(i,k) = v(i,k) * hi
         enddo
      enddo
      
      return
      end

c---------------------------------------------
      subroutine visc_diff (Ri, rnu, rka)
c---------------------------------------------
c     eddy viscosity & diffusivity
c     a'la Pacanowski & Philander [1981]
c---------------------------------------------
c from PP-1981: 
c      parameter (GAMMA = 5., RNU_0 = 0.01, RNU_B = 5.e-5, RKA_B = 5.e-6)
c 
      parameter (GAMMA = 5., RNU_0 = 0.05, RNU_B = 1.34e-5, RKA_B = 1.34e-6)
      parameter (RNU_NEG = RNU_B + RNU_0)
      parameter (RKA_NEG = RKA_B + RNU_NEG)

      if ( Ri .gt. 0. ) then
         tmp = 1. + GAMMA * Ri
         rnu = RNU_B + RNU_0 / (tmp * tmp)
         rka = RKA_B +   rnu / tmp
      else
         rnu = RNU_NEG
         rka = RKA_NEG
      endif

      return
      end

c------------------------------------------------------
      subroutine tria_init (npt, cappa, h)
c------------------------------------------------------
csenq
      include 'comm_para.h'
      real cappa(1), h(npt,1)
      common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ)

      capk   = cappa(1)
      hi     = h(ixy,1)
      tmp    = capk + hi
      betk   = capk / tmp
      bet(1) = betk
      gam(1) = hi   / tmp

      do k = 2, ndim
         betkm1 = betk
         capkm1 = capk
         capk  = cappa(k) 
         hi    = h(ixy,k)

         tmp    = hi + capk + capkm1 - betkm1 * capkm1
         betk   = capk   / tmp
         bet(k) = betk
         aga(k) = capkm1 / tmp
         gam(k) = hi     / tmp
      enddo
      return
      end 

      subroutine tria_run (npt, data)
c-------------------------------------
csenq
      include 'comm_para.h'

      real data(npt,1)
      common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ)

      alfa = data(ixy,1)*gam(1)
      alf(1) = alfa

      do k = 2, ndim
         alfa   = data(ixy,k)*gam(k) + alfa*aga(k) 
         alf(k) = alfa
      enddo

      prev = 0.
      do k = ndim, 1, -1
         prev = alf(k) + bet(k) * prev
         data(ixy,k) = prev
      enddo

      return
      end

      subroutine tria_tem (npt, data, botval)
c--------------------------------------------
csenq
      include 'comm_para.h'

      real data(npt,1)
      common /tria_loc/ ixy, ndim, alf(MAXNZ),bet(MAXNZ),gam(MAXNZ),aga(MAXNZ)

      alfa = data(ixy,1)*gam(1)
      alf(1) = alfa

      do k = 2, ndim
         alfa   = data(ixy,k)*gam(k) + alfa*aga(k) 
         alf(k) = alfa
      enddo

      prev = botval
      do k = ndim, 1, -1
         prev = alf(k) + bet(k) * prev
         data(ixy,k) = prev
      enddo

      return
      end

c****************************************************************************
      subroutine dens_eos(pr, t, s, r0, rr)
c****************************************************************************
c  sub to compute density
c  calls sub 'sbulk', for secant bulk modulas
c
c  r0 is density at p = 0  -  returned in gr cm**3
c  rr is in situ density   -  returned
c

      implicit double precision (a-z)

      real*4  t, s, pr  

c      dimension a(0:5), b(0:4), c(0:2)


       parameter
     1 (a0=999.842594d+00,a1=6.793952d-02,a2=-9.095290d-03,
     2   a3=1.001685d-04,a4=-1.120083d-06,a5=6.536332d-09,

     3  b0=8.24493d-01,b1=-4.0899d-03,b2=7.6438d-05,
     4  b3=-8.2467d-07,b4=5.3875d-09,

     5  c0=-5.72466d-03,c1=1.0227d-04,c2=-1.6546d-06,

     6  d=4.8314d-04)



      if (t.lt.-4.0 .or. t.gt.40.0) then
        r0 = -99.9
        rr = -99.9
        return
      else if (s.lt.0.0 .or. s.gt.42.0) then
        r0 = -99.9
        rr = -99.9
        return
      else if (pr.lt.0.0 .or. pr.gt.10000.0) then
        r0 = -99.9
        rr = -99.9
        return
      end if


      call sbulk(pr, t, s, kk)  
c  secant bulk modulas (k) of seawater
c
c  density of smow
c
      rw = ((((a5*t + a4)*t + a3)*t + a2)*t + a1)*t +a0
c
c  density at p = 0
c
      r0 = rw + s*((((b4*t + b3)*t + b2)*t + b1)*t + b0)
     *     + s*sqrt(s)*((c2*t + c1)*t + c0) + s*s*d 
c
c  in situ density
c
      p = pr / 10.0  
c  p is in bars
      rr = r0 / (1.d0 - p / kk)

      rr = rr / 1.d3  
c  densities are returned in
      r0 = r0 / 1.d3  
c  grams / cubic centimeter

      return
      end



c****************************************************************************
      function theta_eos(p0, t0, s, pf)
c****************************************************************************
c
c to compute local potential temperature at pf
c
c oct 12 1975 n. fofonoff
c

      p = p0
      t = t0
      h = pf - p
      xk = h * atg(p, t, s)

      t = t + 0.5 * xk
      q = xk
      p = p + 0.5 * h
      xk = h*atg(p,t,s)

      t = t + 0.29298322*(xk-q)
      q = 0.58578644*xk + 0.121320344*q
      xk = h*atg(p,t,s)

      t = t + 1.707106781*(xk-q)
      q = 3.414213562*xk - 4.121320344*q
      p = p + 0.5*h
      xk = h*atg(p,t,s)

      theta = t + (xk - 2.0 * q) / 6.0

      return
      end
c****************************************************************************


c****************************************************************************
      subroutine sbulk(pr, t, s, kk)
c****************************************************************************
c
c  subroutines to calculate density, spec vol, secant bulk
c  modulas and alpha & beta
c  based on unesco 1981 report
c  equation of state for seawater - millero
c  programmer - c. greengrove, jan 1982
c  modified for hp - p mele, sep '82
c
c  range:
c    s =  0 to 42 (practical salinity)
c    t = -4 to 40 (c)
c    pr =  0 to 10000 (decibars)
c
c  other units:
c    density = kg/m3 **3
c    bulk deni mod.(k) = bars
c
c
c  kk is secant bulk modulas - returned
c

      implicit double precision (a-z)

      real*4  t, s, pr, s12  
c  single precision


       parameter
     1 (e0=19652.21d+00,e1=148.4206d+00,e2=-2.327105d+00,
     2  e3=1.360477d-02,e4=-5.155288d-05,

     3  f0=54.6746d+00,f1=-.603459d+00,f2=1.09987d-02,f3=-6.167d-05,

     4  g0=7.944d-02,g1=1.6483d-02,g2=-5.3009d-04,

     5  h0=3.239908d+00,h1=1.43713d-03,h2=1.16092d-04,h3=-5.77905d-07,

     6  i0=2.2838d-03,i1=-1.0981d-05,i2=-1.6078d-06,

     7  j=1.91075d-04,

     8  k0=8.50935d-05,k1=-6.12293d-06,k2=5.2787d-08,

     9  m0=-9.9348d-07,m1=2.0816d-08,m2=9.1697d-10)



      if (t.lt.-4.0 .or. t.gt.40.0) then  
c  range specifications
        kk = -99.9
        return
      else if (s.lt.0.0 .or. s.gt.42.0) then
        kk = -99.9
        return
      else if (pr.lt.0.0 .or. pr.gt.10000.0) then
        kk = -99.9
        return
      end if

      p = pr / 10.0  
c  convert to bars
 
c  define sqrt(s)
      s12=sqrt(s)
c
c  secant bulk modulas (k) of seawater
c
c  pure water terms of sbm are w series
c

      kw = (((e4*t + e3)*t + e2)*t + e1)*t + e0
      aw = ((h3*t + h2)*t + h1)*t + h0
      bw = (k2*t + k1)*t + k0
c
c  coeff for final equation
c
      aa = aw + s*((i2*t + i1)*t + i0 + j*s12)
      bb = bw + s*((m2*t + m1)*t + m0)
c
c  sbm at p = 0 first term in the final eq
c
      ko = kw + s*(((f3*t + f2)*t + f1)*t + f0)
     *     + s*s12*((g2*t + g1)*t + g0)
c
c  final eq sbm
c
      kk = (bb*p + aa)*p + ko


      return
      end

c****************************************************************************
      function atg(p, t, s)
c****************************************************************************
c
c adiabatic temperature gradient (bryden 1973)
c

      ds = s - 35.0
      atg = (((-2.1687e-16 * t + 1.8676e-14) * t - 4.6206e-13) * p +
     *      ((2.7759e-12 * t - 1.1351e-10) * ds + ((-5.4481e-14 * t +
     *      8.733e-12) * t - 6.7795e-10) * t + 1.8741e-8)) * p +
     *      (-4.2393e-8 * t + 1.8932e-6) * ds + ((6.6228e-10 * t -
     *      6.836e-8) * t + 8.5258e-6) * t + 3.5803e-5


      return
      end


c     ------------------------------------------------------------------
      subroutine comp_bncy (npt,nzi,dens,bncy)
c     ------------------------------------------------------------------
c     Compute boyoncy as : b = -g(rho-rho_0)/rho_0
c     ------------------------------------------------------------------
      include 'comm_para.h'
      include 'comm_new.h'

      dimension dens(npt,1),bncy(npt,1),nzi(npt)
c
      if ( use_salt ) then
         coef = -GRAVTY/(1000. + POTND_BOT)
         do i = 1, npt
            do k = 1, nzi(i)
               bncy(i,k) = coef * (dens(i,k) - POTND_BOT)
            enddo
         enddo
      endif
      return
      end

c     ------------------------------------------------------------------
      subroutine cvmix(npt,nzi,h,t,s,b,u,v)
c     ------------------------------------------------------------------
c     Convective adjustment as of Dake Chen.
      include 'comm_new.h'

      dimension nzi(npt),h(npt,1),t(npt,1),s(npt,1),b(npt,1),u(npt,1),v(npt,1)
c
      if ( use_salt ) then
         do ns = 1, 2
         do ks = 1, 2
            do i = 1, npt
               do k = ks, nzi(i)-1, 2
                  k1 = k + 1
                  if (b(i,k) .lt. b(i,k1)) then
                     hik  = h(i,k)
                     hik1 = h(i,k1)
                     hsum1 = 1. / (hik + hik1)
                     t(i,k)  = (hik*t(i,k) + hik1*t(i,k1))*hsum1
                     t(i,k1) =  t(i,k)
                     s(i,k)  = (hik*s(i,k) + hik1*s(i,k1))*hsum1
                     s(i,k1) =  s(i,k)
                     b(i,k)  = (hik*b(i,k) + hik1*b(i,k1))*hsum1
                     b(i,k1) =  b(i,k)
                  endif
               enddo
            enddo
         enddo
         enddo
      else
         do ns = 1, 2
         do ks = 1, 2
            do i=1,npt
               do k = ks, nzi(i)-1, 2
                  if (t(i,k) .lt. t(i,k+1)) then
                     hsum   = h(i,k)+h(i,k+1)
                     t(i,k) = (h(i,k)*t(i,k)+h(i,k+1)*t(i,k+1))/hsum
                     t(i,k+1) = t(i,k)
                  endif
               enddo
            enddo
         enddo
         enddo
      endif

      return
      end

c     ----------------------------------------------------------------
      function tke0(wp,b0,br,h,hp)
c     ----------------------------------------------------------------
        hp2 = hp + hp
	hexp = h - hp2 + (h + hp2)*exp(-h/hp)
        bp   = b0*h + br*hexp
	tke0 = wp - bp
      return
      end

c     ---------------------------------------------------------------------
      subroutine ktmix(npt,nsig,ddt,h,t,s,b,u,v,q,qr,ep,taux,tauy,sigma,dh1)
c     ---------------------------------------------------------------------
c     Vertical Mixing Using Kraus-Turner Scheme.(Dake Chen, 1995)

      include 'comm_new.h'

      dimension u(npt,1),v(npt,1),h(npt,1),t(npt,1),s(npt,1),b(npt,1),
     +          dh1(1),q(1),qr(1),ep(1),taux(1),tauy(1),sigma(1)
      data alph/2.55e-4/, beta/7.6e-4/, gravty/9.8/, taumin/3.e-5/, hp/17./
c
      ga = alph*gravty
      gb = beta*gravty
c
      cm2 = 2.0 * cm_mix
      cn2 = cn_mix / 2.0

      do i = 1, npt
         h10 = h(i,1)
         tau = sqrt(taux(i)**2 + tauy(i)**2)
         tau = amax1(tau,taumin)
         ustar = sqrt(tau)
         wp = cm2 * ustar * tau
         br = ga*qr(i)
         if ( use_salt ) then
            b0  = ga*q(i) - gb*ep(i)
            dbh = (b(i,1) - b(i,2))*h10
         else
            b0  = ga*q(i)
            dbh = ga*(t(i,1) - t(i,2))*h10
         endif

         b0 = b0 - cn2 * (b0-abs(b0))
         dbh = amax1(dbh,1.e-5)

         tke = tke0(wp,b0,br,h10,hp)
         if( tke .lt. 0.) then
            h1 = h10
            h2 = 0.5*h1
            f1 = tke0(wp,b0,br,h1,hp)
            do iter = 1, 10
               f2   = tke0(wp,b0,br,h2,hp)
               hnew = h2 - f2*(h2-h1)/(f2-f1)
               err  = abs(hnew-h2)/h2
               if (err .lt. 1.e-4) goto 15
               h1 = h2
               h2 = hnew
               f1 = f2
            enddo
   15       continue
            hnew = amin1(h10, hnew)
         else
            h1 = h10
            h2 = h10 + h10
            hm = h10
            f1 = -ddt*tke0(wp,b0,br,hm,hp)
            do iter = 1, 10
               hm   = 0.5*(h2+h10)
               f2   = dbh*(h2-h10) - ddt*tke0(wp,b0,br,hm,hp)
               hnew = h2 - f2*(h2-h1)/(f2-f1)
               err  = abs(hnew-h2)/h2
               if (err .lt. 1.e-4) goto 25
               h1 = h2
               h2 = hnew
               f1 = f2
            enddo
   25       continue
            hnew = amax1(h10, hnew)
         endif

         hnew = amax1(hmin_mix, hnew)
         hnew = amin1(hmax_mix, hnew)
         dh     = hnew - h10
         adh    = amin1(abs(dh), h(i,2))
         dh1(i) = sign(adh, dh)
         
      enddo

      call impmix (npt,nsig,dh1,u,v,h,t,s,sigma)

      return
      end

c     ----------------------------------------------------------------
      subroutine impmix (npt,nz,dh1,u,v,h,t,s,sigma)
c     ----------------------------------------------------------------
c     Adjust vertical profiles according to the depth change of the 
c     mixed layer as of Dake Chen. /modified by Senya Basin, July 1995/

      include 'comm_para.h'
      include 'comm_new.h'

      dimension dh1(1),u(npt,1),v(npt,1),h(npt,1),
     *     t(npt,1),s(npt,1), sigma(1),
     *     u1(MAXNZ),u2(MAXNZ),v1(MAXNZ),v2(MAXNZ),t1(MAXNZ),t2(MAXNZ),
     *     aa(MAXNZ),bb(MAXNZ),cc(MAXNZ),dh(MAXNZ),we(MAXNZ),hr(MAXNZ),
     *     s1(MAXNZ),s2(MAXNZ)

      do i = 1, npt
         dh_mix = dh1(i)

         if (dh_mix .ne. 0.) then

            dh(1) = dh_mix
            do k = 2, nz
               dh(k) = -1.5*(sigma(k)+sigma(k+1))*dh_mix
            enddo
            
            we(1) = dh_mix
            do k = 2, nz-1
               we(k) = we(k-1) + dh(k)
            enddo

            if (use_salt) then
               do k = 1, nz
                  hik = h(i,k)
                  u1(k)  = u(i,k)*hik
                  v1(k)  = v(i,k)*hik
                  t1(k)  = t(i,k)*hik
                  s1(k)  = s(i,k)*hik
                  h(i,k) = hik + dh(k)
               enddo
            else
               do k = 1, nz
                  hik = h(i,k)
                  u1(k)  = u(i,k)*hik
                  v1(k)  = v(i,k)*hik
                  t1(k)  = t(i,k)*hik
                  h(i,k) = hik + dh(k)
               enddo
            endif

           do k = 1, nz-1
              hr(k) = we(k)/(h(i,k)+h(i,k+1))
           enddo

           hr1 = 0.5*(dh_mix - abs(dh_mix)) / h(i,1)
           hr2 = 0.5*(dh_mix + abs(dh_mix)) / h(i,2)
           cc(1) = -hr2
           bb(1) = 1. - hr1
           aa(2) = hr1
           cc(2) = -hr(2)
           bb(2) = 1. - hr(2) + hr2
           aa(nz) = hr(nz-1)
           bb(nz) = 1. + aa(nz)

           hr_k = hr(2)
           do k = 3, nz-1
              hr_km1 = hr_k
              hr_k   = hr(k)
              aa(k) =  hr_km1
              cc(k) = -hr_k
              bb(k) = 1. + hr_km1 - hr_k
           enddo

           call tridiag(aa,bb,cc,u1,u2,nz)
           call tridiag(aa,bb,cc,v1,v2,nz)
           call tridiag(aa,bb,cc,t1,t2,nz)

           if ( use_salt ) then
              call tridiag(aa,bb,cc,s1,s2,nz)
              do k = 1, nz
                 hik = 1./h(i,k)
                 u(i,k) = hik*u2(k)
                 v(i,k) = hik*v2(k)
                 t(i,k) = hik*t2(k)
                 s(i,k) = hik*s2(k)
              enddo
           else
              do k = 1, nz
                 hik = 1./h(i,k)
                 u(i,k) = hik*u2(k)
                 v(i,k) = hik*v2(k)
                 t(i,k) = hik*t2(k)
              enddo
           endif
        endif
      enddo  

      return
      end

c     ------------------------------------------------------------------
      subroutine jpmix (npt,nz,nzi,h,t,s,b,u,v)
c     ------------------------------------------------------------------
c     Reduce gradient Richardson # instability using a Jim Price criterion.

      include 'comm_para.h'
      include 'comm_new.h'
      dimension u(npt,1),v(npt,1),h(npt,1),t(npt,1),s(npt,1),b(npt,1),
     *          gama(MAXNZ), ric(MAXNZ), nzi(npt)
      logical use_gamma

      save EPSILON, use_gamma, ifirst, ric, ric_inv

      data EPSLON/1.e-9/, ifirst/0/
c
      if ( ifirst .eq. 0 ) then
         ifirst = 1
         gama(1)    = gam1_mix
         ric(1)     = ric1_mix
         do k = 2, nz
            gama(k)    = gam2_mix
            ric(k)     = ric2_mix
         enddo
         use_gamma = (iuse_gam .eq. 1)
      endif

      if ( use_salt ) then
         do kn = 1, 2
         do ks = 1, 2
            do i = 1, npt
               do k = ks, nzi(i)-1, 2

               Rik      = ric(k)
               Rik_inv  = 1./ric(k)
               gamkt    = gama(k)
               gamkv    = 0.5*(1.+gama(k))

c     compute the gradient Richardson number
                  hm = h(i,k) + h(i,k+1)
                  bd = b(i,k) - b(i,k+1)
                  dd = 0.5 * hm * bd
                  
                  ud = u(i,k+1) - u(i,k)  
                  vd = v(i,k+1) - v(i,k) 
                  dv = ud*ud + vd*vd
                  Ri = amax1(dd,0.)/amax1(dv,EPSLON)
c     check to see if Ri is critical or not
                  
                  if (Ri .lt. Rik) then
c     partially mix layers k and k+1
                     if ( use_gamma ) then
                        ri2 = Ri*Rik_inv
                        ct = 1.- ri2**gamkt
                        cv = 1.- ri2**gamkv
                     else
                        ct = 1. - Ri*Rik_inv
                        cv = ct
                     endif
                     c1 = h(i,k)   / hm
                     c2 = h(i,k+1) / hm
                     td = (t(i,k+1)-t(i,k))*ct
                     sd = (s(i,k+1)-s(i,k))*ct
                     bd = -bd*ct
                     ud = ud*cv
                     vd = vd*cv
                     
                     t(i,k+1) = t(i,k+1) - td*c1
                     t(i,k)   = t(i,k)   + td*c2
                     
                     s(i,k+1) = s(i,k+1) - sd*c1
                     s(i,k)   = s(i,k)   + sd*c2
                     
                     b(i,k+1) = b(i,k+1) - bd*c1
                     b(i,k)   = b(i,k)   + bd*c2
                     
                     u(i,k+1) = u(i,k+1) - ud*c1
                     u(i,k)   = u(i,k)   + ud*c2
                     v(i,k+1) = v(i,k+1) - vd*c1
                     v(i,k)   = v(i,k)   + vd*c2
                  endif
               enddo
            enddo
         enddo
         enddo
      else

         coef = TALPHA*GRAVTY / 2.0

         do kn = 1, 2
         do ks = 1, 2
            do i = 1, npt
               do k = ks, nzi(i)-1, 2
                  
                  Rik      = ric(k)
                  Rik_inv  = 1./ric(k)
                  gamkt    = gama(k)
                  gamkv    = 0.5*(1.+gama(k))
                  
c     compute the gradient Richardson number
                  hm = h(i,k) + h(i,k+1)
                  td = t(i,k) - t(i,k+1)
                  dd = coef * hm * td
                  
                  ud = u(i,k+1) - u(i,k)  
                  vd = v(i,k+1) - v(i,k) 
                  dv = ud*ud + vd*vd
                  Ri = amax1(dd,0.)/amax1(dv,EPSLON)
c     check to see if Ri is critical or not
                  
                  if (Ri .lt. Rik) then
c     partially mix layers k and k+1
                     if ( use_gamma ) then
                        ri2 = Ri*Rik_inv
                        ct = 1.- ri2**gamkt
                        cv = 1.- ri2**gamkv
                     else
                        ct = 1. - Ri*Rik_inv
                        cv = ct
                     endif
                     c1 = h(i,k)/hm
                     c2 = h(i,k+1)/hm
                     td = -td*ct
                     ud = ud*cv
                     vd = vd*cv
                     
                     t(i,k+1) = t(i,k+1) - td*c1
                     t(i,k)   = t(i,k)   + td*c2
                     
                     u(i,k+1) = u(i,k+1) - ud*c1
                     u(i,k)   = u(i,k)   + ud*c2
                     v(i,k+1) = v(i,k+1) - vd*c1
                     v(i,k)   = v(i,k)   + vd*c2
                  endif
               enddo
            enddo
         enddo
         enddo
      endif

      return
      end


c----------------------------------------------------------------------------
      subroutine tridiag(A,B,C,Y,X,N)
c----------------------------------------------------------------------------

c	Modified 2 Feb 1991

c	This routine solves a matrix equation of the form MX=Y where Y is
c	the know vector and M is an NxN tridiagonal matrix with a diagonal of
c	B, a lower diagonal of A and an upper diagonal of C.  It should be
c	noted that N will be equal to the number of layers (nz).  If there
c	are more than 100 the array size will exceed memory allocation.
c
c	This routine requires the matrix elements (A,B,C), the known vector
c	(Y) and the dimensions of both (N).
c
c	This routine supplies the new vector X.
c	The variables are defined as:
c
c	    Name	       Type		Description
c	    ====	       ====		===========
c
c	a(n)                  From      Lower diagonal elements
c			      dimpl 
c	b(n)		      From      Main diagonal elements
c			      dimpl
c	bit		      Internal  Storage variable
c	c(n)                  From      Upper diagonal elements
c			      dimpl   
c	gam(nmax)	      Internal  Storage array
c	nmax                  Internal  Maximum array size
c	x(n)                  Ret to    new velocity (temp) field
c			      dimpl
c	y(n)		      From      Original velocity (temp) field
c			      dimpl
c

c------------------ Establish variables and constants -----------------------
      parameter (nmax=100)
      dimension gam(nmax),a(n),b(n),c(n),y(n),x(n)

      bet  = b(1)
      x(1) = y(1)/bet
c-------------------------- Forward substitute ------------------------------
      do j = 2, n
         gam(j) = c(j-1)/bet
         bet    = b(j) - a(j)*gam(j)
         x(j)   = (y(j) - a(j)*x(j-1)) / bet
      enddo
c-------------------------- Back substitute ------------------------------
      do j = n-1, 1, -1
         x(j) = x(j) - gam(j+1)*x(j+1)
      enddo

      return
      end


dyn_diff.f/     844712210   1572  1572  100444  23469     `
c  dyn_diff.f is a collection of fortran routines that will
c  allow to diffuse tracers along isopyncal surfaces and also
c  reduce the available potential energy by adding eddy induced
c  velocities to the eulerian mean velocities
c  first the density slope needs to be determined CALL SLOPE
c  then the isopycnal diffusion  can be computed  CALL DIFF_ISO
c  finally the eddy induced velocities are obtained CALL ADV_ISO
c
c  you need to add those to the Eulerian u,v,w BEFORE the advection
c  is called.
c
c  PARAMETER:
c    sigzmin : minimum vertical density gradient  (1e-6 [kg/m^4])
c    coef_diff_adv(z) : transfer coef for eddy induced velocity (1000 [m^2/s])
c    slmax : maximum slope for isopycnal diffusion (1e-2)
c    alpha  :  1 isopycnal diffusion, 0 horizontal diffusion 
c    coef_diff(z) : isopycnal diffusion coeff (1000 [m^2/s])
c    eps : ratio between isopycnal and diapycnal mixing (0)
c    
c   version 1.0 Aug 1996
c   Martin Visbeck
c
      subroutine diff_init(npt,iglob,mgrid)
      include 'comm_data.h'
      include 'comm_diff.h'
      parameter (TORAD = 3.14159265/180., REARTH = 6378000.)
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc

      do k = 1, npt
         j = (iox(k)-1)/nxp + 1
         i = iox(k) - (j-1)*nxp
         if (j.lt.nyp) then
            dyp(k) = TORAD * REARTH * (ym(j+1)-ym(j))
            if (j.gt.1) then
               dym2(k) = TORAD * REARTH * (ym(j+1)-ym(j-1))
            else
               dym2(k) = dyp(k)
            endif
         else 
            dyp(k) = TORAD * REARTH * (ym(nyp)-ym(nyp-1))
            dym2(k) = dyp(k)
         endif
         dym(k) = dym2(k)/2.

         if (mgrid.eq.2) then
            csy(k) = cos(TORAD * ym(j))
            csyc(k) = cos(TORAD * (ym(j) + dyp(k)/2.))
         else
            csy(k) = cos(TORAD * (ym(nyp)+ym(1))/2.)
            csyc(k)= csy(k)
         endif
         
         deg2met  = TORAD * REARTH * csy(k)
         
         if (i.lt.nxp) then
            dxp(k) = deg2met * (xm(i+1) - xm(i))
            if (i.gt.1) then
               dxm2(k) = deg2met * (xm(i+1) - xm(i-1))
            else
               dxm2(k) = dxp(k)
            endif
         else 
            dxp(k) = deg2met * (xm(nxp) - xm(nxp-1))
            dxm2(k) = dxp(k)
         endif
         dxm(k) = dxm2(k)/2.
      enddo
      
      if (iglob.eq.1) then
         do k = 1, npt
            deg2met  = TORAD * REARTH * csy(k)
            j = (iox(k)-1)/nxp + 1
            i = iox(k) - (j-1)*nxp
            if (i.eq.1) then
               dxm2(k)=deg2met*((xm(2)-xm(1))+(xm(nxp)-xm(nxp-1)))
               dxm (k)=deg2met*(xm(2)-xm(1))
            endif
            if (i.eq.nxp) then
               dxm2(k)=deg2met*((xm(2)-xm(1))+(xm(nxp)-xm(nxp-1)))
               dxm (k)=deg2met*(xm(nxp)-xm(nxp-1))
               dxp (k)= dxm2(k)/2.
            endif
         enddo
      endif
         
      return
      end


c     ------------------------------------------------------------------
      subroutine diff_iso(coef_diff,npt,nzi,h,tr,ftr,
     *       lxxk,lyyk,snxk,snyk,isyk,isk,tp,lpbcwk,lpbcek)
c     ------------------------------------------------------------------

c     input:
c        h   - layer depths
c        tr  - tracer quantity (times h)
c       ftr  - forcing term to which diffusion will be added
c       slx,sly  - isopycnal slopes
c       coef_diff - diffusion coeficient
c       eps  - ratio of diapyncal / isopycnal
c       alpha - mixing slope (0-horizontal, 1-isopycnal)
c     output:
c       ftr  - forcing term to which diffusion will be added
c     diagnostics:
c       gtr  - diffusion tensor quantity  
c       trx,try,trz - tracer gradients
c       

c     subroutine that calculates diffusion tensor term in the
c         tracer equations
 
      include 'comm_para.h'
      include 'comm_diff.h'
      include 'diffiso.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +        ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension h(npt,nz),tr(npt,nz),ftr(npt,nz), tp(npt)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz), nzi(npt)

 
      alpha = diffiso_alpha
      eps   = diffiso_eps
      slmax = diffiso_slmax

      if (alpha.eq.0) then

         do k = 1, nz   
            npk = nptk(k)
            nxk = nbxk(k)
            nyk = nbyk(k)
            nck = ncsk(k)
            npbk = npbck(k)
            
            call dfdx_a2c(tr(1,k),gtr,npt,npk,nxk,nck,lxxk(1,k),
     *           snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k),dxp)
            call dfdx_c2a(gtr,tp,npt,npk,nxk,nck,lxxk(1,k),
     *           snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k),dxm)
            
            do j = 1, npk
               i = isk(j,k)
               ftr(i,k) = ftr(i,k) + coef_diff*tp(i)
            enddo
            
            call dfdy_a2c(tr(1,k),gtr,npt,npk,nyk,nck,lyyk(1,k),
     *           snyk(1,k),isyk(1,k),dyp)
            call dfdy_c2a(gtr,tp,npt,npk,nyk,nck,lyyk(1,k),
     *           snyk(1,k),isyk(1,k),dym,csy,csyc)
            
            do j = 1, npk
               i = isk(j,k)
               ftr(i,k) = ftr(i,k) + coef_diff*tp(i)
            enddo
         enddo
         
      else
         
c.....compute vertical tracer gradient 
      call dfdz_ff(tr,trz,npt,nz,nzi,h)

c.....compute horizontal tracer gradient 
      do k = 1, nz  
         npk = nptk(k)
         nxk = nbxk(k)
         nyk = nbyk(k)
         nck = ncsk(k)
         npbk = npbck(k)

         call dfdx_ff(tr(1,k),trx(1,k),npt,npk,nxk,nck,lxxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k),dxm2)
         call dfdy_ff(tr(1,k),try(1,k),npt,npk,nyk,nck,lyyk(1,k),
     *       snyk(1,k),isyk(1,k),dym2)
      enddo

c do diffusion in x-direction
      do k = 1, nz   
c.....multiply gradients with slopes and diffusion factors  
         npk = nptk(k)
         nxk = nbxk(k)
         nyk = nbyk(k)
         nck = ncsk(k)
         npbk = npbck(k)

         call dfdx_a2c(tr(1,k),tp,npt,npk,nxk,nck,lxxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k),dxp)
         do j = 1, npk - 1
            i = isk(j,k)
            ip= i + 1
            ax= alpha*(slx(i,k)+slx(ip,k))/2.
            ay= alpha*(sly(i,k)+sly(ip,k))/2.
            ax2 = ax*ax
            ay2 = ay*ay
            axy = ax*ay
            sl = sqrt(ax2 + ay2)
            slfac =  max(0.,1. - sl/slmax * slred)
            eps1 = (1-eps)
            fac = coef_diff/(1+ax2+ay2)
            tryc = (try(i,k)+try(ip,k))/2.
            trzc = (trz(i,k)+trz(ip,k))/2.
         
            gtr(i) = fac*(
     *           (1+eps*ax2+ay2)*tp(i) 
     *              + (-axy*eps1*tryc + ax*eps1*trzc)*slfac)

         enddo                     
         call dfdx_c2a(gtr,tp,npt,npk,nxk,nck,lxxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k),dxm)

         do j = 1, npk
            i = isk(j,k)
            ftr(i,k) = ftr(i,k) + tp(i)
         enddo
      enddo

c do diffusion in y-direction
      do k = 1, nz   
c.....multiply gradients with slopes and diffusion factors  
         npk = nptk(k)
         nxk = nbxk(k)
         nyk = nbyk(k)
         nck = ncsk(k)
         npbk = npbck(k)

         call dfdy_a2c(tr(1,k),tp,npt,npk,nyk,nck,lyyk(1,k),
     *       snyk(1,k),isyk(1,k),dyp)
         do j = 1, npk - 1
            i = isyk(j,k)
            ip= isyk(j+1,k)
            ax= alpha*(slx(i,k)+slx(ip,k))/2.
            ay= alpha*(sly(i,k)+sly(ip,k))/2.
            ax2 = ax*ax
            ay2 = ay*ay
            axy = ax*ay
            sl = sqrt(ax2 + ay2)
            slfac =  max(0.,1. - sl/slmax * slred)
            eps1 = (1-eps)
            fac = coef_diff/(1+ax2+ay2)
            trxc = (trx(i,k)+trx(ip,k))/2.
            trzc = (trz(i,k)+trz(ip,k))/2.
         
            gtr(i) = fac*(
     *             -axy*eps1*trxc*slfac + (1+ax2+eps*ay2)*tp(i) 
     *            + ay*eps1*trzc*slfac)
         enddo                     

         call dfdy_c2a(gtr,tp,npt,npk,nyk,nck,lyyk(1,k),
     *       snyk(1,k),isyk(1,k),dym,csy,csyc)

         do j = 1, npk
            i = isk(j,k)
            ftr(i,k) = ftr(i,k) + tp(i)
         enddo
      enddo

c do diffusion in z-direction
      call dfdz_a2c(tr,trz,npt,nz,nzi,h)

      do i = 1, npt
         nzb = nzi(i)
         do k = 1, nzb-1
            kp = k + 1
            ax= alpha*(slx(i,k)+slx(i,kp))/2.
            ay= alpha*(sly(i,k)+sly(i,kp))/2.
            ax2 = ax*ax
            ay2 = ay*ay
            axy = ax*ay
            sl = sqrt(ax2 + ay2)
            slfac =  max(0.,1. - sl/slmax * slred)
            eps1 = (1-eps)
            fac = coef_diff/(1+ax2+ay2) * slfac
            trxc = (trx(i,k)+trx(i,kp))/2.
            tryc = (try(i,k)+try(i,kp))/2.
            
            gtrz(i,k) = fac * ( 
     *              ax*eps1*trxc + ay*eps1*tryc + (eps+ax2+ay2)*trz(i,k))

          enddo
       enddo
 
      call dfdz_c2a(gtrz,trz,npt,nz,nzi,h)

      do k = 1, nz    
         npk = nptk(k)
         do j = 1, npk
            i = isk(j,k)
            ftr(i,k) = ftr(i,k) + trz(i,k)
         enddo
      enddo
      endif

      return
      end

c     ------------------------------------------------------------------
      subroutine adv_iso(sig,ucs,vcs,uc,vc,h,npt,nz,nzi,facz)
c     ------------------------------------------------------------------
c     input:
c       sigx,sigy - horizontal density gradients (central diff)
c       sigz      - vertical density gradient (plain diff) 
c       sigzmin   - add to sigz to get more stable psi
c       coef_diff_adv - transfer coeficeint [m^2/s]
c       facz      - a tapering-off factor
c     output:
c       advection velocities us,vs,ws
c     diagnostics:
c       streamfunction psix,psiy [m^2/s]
c
c           |---- sigx----|
c       
c     -     +      +      +      z_k   sig,sigx,sigy,us,vs (A-grid)
c     |
c   sigz    *      *      *           sigz,sigxx,sigyy,psix,psiy,ws grid 
c     |
c     -     +      +      +      z_k+1
c
c          x_i-1  x_i    x_i+1
c
c     subroutine that calculates eddy induced velocities us,vs,ws
c     to be added to eulerian mean velocities for tracer transfer.
c
c     M. Visbeck, version 1.0 Aug 1996
 
      include 'comm_diff.h'
      include 'diffiso.h'

      dimension nzi(npt),facz(nz)
      dimension sig(npt,nz), ucs(npt,nz),vcs(npt,nz),uc(npt,nz),vc(npt,nz),
     *          h(npt,nz)

      call dfdz_a2c(sig,sigz,npt,nz,nzi,h)

      cadv = diffiso_cadv
      
c.....compute vector stream function psix,psiy 
      do i = 1, npt
         do k = 1, nzi(i)-1    
            k1 = k + 1
            
c.... vertical mean horizontal density gradient (could be done more careful)
            sigxx = 0.5 * (sigx(i,k) + sigx(i,k1))
            sigyy = 0.5 * (sigy(i,k) + sigy(i,k1))
            
c..... increase vertical stratification to ensure stability
            psix(i,k) = psix(i,k) + psi_rel*(facz(k)*cadv * sigxx / (sigz(i,k)+sigzmin)-psix(i,k))
            psiy(i,k) = psiy(i,k) + psi_rel*(facz(k)*cadv * sigyy / (sigz(i,k)+sigzmin)-psiy(i,k))
         enddo
      enddo 
      
c....... derive velocities from stream function
      call dfdz_c2a(psix,ucs,npt,nz,nzi,h)
      call dfdz_c2a(psiy,vcs,npt,nz,nzi,h)
      
c....... compute modified layer transports
      do i = 1, npt
         do k = 1, nzi(i)
            ucs(i,k) = uc(i,k) + h(i,k)*ucs(i,k)
            vcs(i,k) = vc(i,k) + h(i,k)*vcs(i,k)
         enddo
      enddo
      
      return
      end
      
c     ------------------------------------------------------------------
      subroutine slope(npt,sig,nzi,h,
     *        lxxk,lyyk,snxk,snyk,isyk,isk,lok,tp,lpbcwk,lpbcek)
c     ------------------------------------------------------------------

c     input:
c       sig  - potential density
c       slmax - maximum allowed slope for slx,sly
c     output:
c       sigx,sigy - horizontal density gradients (central)
c       sigz    - vertical density gradient (plain)
c       slx  - zonal slope of density surfaces (A-grid)
c       sly  - meridional slope of density surfaces (A-grid)

c     subroutine that calculates slopes of density surfaces
 
      include 'comm_para.h'
      include 'diffiso.h'
      include 'comm_diff.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     *    ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension sig(npt,nz),nzi(nz),h(npt,nz)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz)
 

      slmax = diffiso_slmax

c..... compute vertical density gradients, centered, for use here only
      call dfdz_ff(sig,sigz,npt,nz,nzi,h)

      do k = 1, nz  
         npk = nptk(k)
         nxk = nbxk(k)
         nyk = nbyk(k)
         nck = ncsk(k)
         npbk = npbck(k)
         nok = nlok(k)

c.....compute horizontal gradients
         call dfdx_ff(sig(1,k),sigx(1,k),npt,npk,nxk,nck,lxxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k),dxm2)
         call dfdy_ff(sig(1,k),sigy(1,k),npt,npk,nyk,nck,lyyk(1,k),
     *       snyk(1,k),isyk(1,k),dym2)

c..... compute slopes
         do j = 1, npk
            i = isk(j,k)
            sigz(i,k) = min(sigz(i,k),0.)
            slx(i,k) = - sigx(i,k)/
     *                 min(sigz(i,k),sigzmin-abs(sigx(i,k)/slmax))
            sigx(i,k) = - slx(i,k)*(sigz(i,k)+sigzmin)
            sly(i,k) = - sigy(i,k)/
     *                 min(sigz(i,k),sigzmin-abs(sigy(i,k)/slmax))
            sigy(i,k) = - sly(i,k)*(sigz(i,k)+sigzmin)
         enddo

      enddo


      return
      end

c     ---------------------------------------------------------------------
      subroutine dfdx_ff (f,df,npt,npk,nbx,ncs,lxx,snx
     *           ,npbc,lpbcw,lpbce,isk,dx)
c     ---------------------------------------------------------------------
      dimension f(npt),df(npt),snx(nbx),lxx(nbx+ncs,4)
      dimension lpbcw(npbc), lpbce(npbc),isk(npk),dx(npt)

      do i = 2, npk - 1
         j = isk(i)
         df(j) = (f(j+1)-f(j-1))/dx(j)
      enddo
c....................... periodic B.C.
      do i = 1, npbc
         i2 = lpbce(i)
         f4 = f(i2)
         f3 = f(i2-1)

         i1 = lpbcw(i)
         f5 = f(i1)
         f6 = f(i1+1)

         df(i1)   = (f6 - f4)/dx(i1)
         df(i2)   = (f5 - f3)/dx(i2)
      enddo
      
      do i = 1, nbx
         i1 = lxx(i,1)
         i2 = lxx(i,2)
         f1 = f(i1)
         f2 = f(i2)
         df(i1) = snx(i)*(f2-f1)/dx(i1)
      enddo

      return
      end

c     ---------------------------------------------------------------------
      subroutine dfdx_a2c (f,df,npt,npk,nbx,ncs,lxx,snx
     *           ,npbc,lpbcw,lpbce,isk,dxp)
c     ---------------------------------------------------------------------
      dimension f(npt),df(npt),snx(nbx),lxx(nbx+ncs,4)
      dimension lpbcw(npbc), lpbce(npbc),isk(npk),dxp(npt)

      do i = 1, npk - 1
         j = isk(i)
         df(j) = (f(j+1)-f(j))/dxp(j)
      enddo
c....................... periodic B.C.
      do i = 1, npbc
         ie = lpbce(i)
         iw = lpbcw(i)
         df(ie)   = (f(iw) - f(ie))/dxp(ie)
      enddo
      
      return
      end

c     ---------------------------------------------------------------------
      subroutine dfdx_c2a (f,df,npt,npk,nbx,ncs,lxx,snx
     *           ,npbc,lpbcw,lpbce,isk,dxm)
c     ---------------------------------------------------------------------
      dimension f(npt),df(npt),snx(nbx),lxx(nbx+ncs,4)
      dimension lpbcw(npbc), lpbce(npbc),isk(npk),dxm(npt)

      do i = 2, npk
         j = isk(i)
         df(j) = (f(j)-f(j-1))/dxm(j)
      enddo
c....................... periodic B.C.
      do i = 1, npbc
         ie = lpbce(i)
         iw = lpbcw(i)
         df(iw)   = (f(iw) - f(ie))/dxm(iw)
      enddo
      
      do i = 1, nbx
         i1 = lxx(i,1)
         i2 = lxx(i,2)
         f1 = f(i1)
         if (snx(i).lt.0) f1 = -f(i2)
         df(i1) = f1/dxm(i1)
      enddo

      return
      end

c     ------------------------------------------------------------------
      subroutine dfdy_ff(f,df,npt,npk,nby,ncs,lyy,sny,isy,dy)
c     ------------------------------------------------------------------
c      dfdy in flux form
      implicit real(a-h,o-z),integer(i-n)
      dimension f(npt),df(npt),sny(nby),lyy(nby+ncs,4)
     *          ,isy(npk),dy(npt)
c   note, isy: k-y-comp  -> x-comp, 
c         lyy: k-y-comp-bound -> x-comp , etc.
c
      do i = 2, npk-1
         j   = isy(i)
         jp  = isy(i+1)
         jm  = isy(i-1)
         df(j)=(f(jp)-f(jm))/dy(j)
      enddo
      
      do i = 1, nby
         i1 = lyy(i,1)
         i2 = lyy(i,2)
         df(i1) = sny(i)*(f(i2)-f(i1))/dy(i1)
      enddo

      return
      end

c     ------------------------------------------------------------------
      subroutine dfdy_a2c(f,df,npt,npk,nby,ncs,lyy,sny,isy,dyp)
c     ------------------------------------------------------------------
c      dfdy in flux form
      implicit real(a-h,o-z),integer(i-n)
      dimension f(npt),df(npt),sny(nby),lyy(nby+ncs,4)
     *          ,isy(npk),dyp(npt)
c
      do i = 1, npk-1
         j   = isy(i)
         jp  = isy(i+1)
         df(j)=(f(jp)-f(j))/dyp(j)
      enddo
      
      return
      end

c     ------------------------------------------------------------------
      subroutine dfdy_c2a(f,df,npt,npk,nby,ncs,lyy,sny,isy,dym,csy,csyc)
c     ------------------------------------------------------------------
c      dfdy in flux form, from c-grid to a-grid
      implicit real(a-h,o-z),integer(i-n)
      dimension f(npt),df(npt),sny(nby),lyy(nby+ncs,4)
     *          ,isy(npk),csyc(npt),dym(npt),csy(npt)
c
      do i = 2, npk
         j   = isy(i)
         jm  = isy(i-1)
         df(j)=(csyc(j)*f(j)-csyc(jm)*f(jm))/(dym(j)*csy(j))
      enddo
      
      do i = 1, nby
         i1 = lyy(i,1)
         f1 = csyc(i1)*f(i1)
         i2 = lyy(i,2)
         if (sny(i).lt.0) f1 = -csyc(i2)*f(i2)
         df(i1) = f1/(dym(i1)*csy(i1))
      enddo

      return
      end

      subroutine dfdz_ff(f,df,npt,nz,nzi,h)
c-------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension h(npt,nz), f(npt,nz), df(npt,nz)
      dimension nzi(npt)

c.....    nzi  : number of layers
c.....    h    : layer depth
c.....    f    : quantity to be differentiated
c.....    df   : (central difference) vertical derivative of tracer 
c
      do i = 1, npt
         nzb = nzi(i)
         do k=  2, nzb -1
            kp = k + 1
            km = k - 1
            fp = f(i,kp)   
            fm = f(i,km)   
            df(i,k) = (fm - fp) / (2.*h(i,k))
         enddo
         df(i,1  ) = (f(i,1) - f(i,2)) / h(i,1)
         df(i,nzb) = (f(i,nzb-1) - f(i,nzb)) / h(i,nzb)
      enddo
      
      return
      end

      subroutine dfdz_a2c(f,df,npt,nz,nzi,h)
c-------------------------------------------------------------
c  a-grid means layer centers
c  c-grid means layer interfaces
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension h(npt,nz), f(npt,nz), df(npt,nz)
      dimension nzi(npt)

c.....    nzi  : number of layers
c.....    h    : layer depth
c.....    f    : quantity to be differentiated
c.....    df   : vertical derivative of tracer 
c
      do i = 1, npt
         nzb = nzi(i)
         dz = h(i,1)
         do k=  1, nzb -1
            kp = k + 1
            dz = 2.*h(i,k) - dz
            df(i,k) = (f(i,k) - f(i,kp)) / dz
         enddo
      enddo
      
      return
      end


      subroutine dfdz_c2a(f,df,npt,nz,nzi,h)
c-------------------------------------------------------------
c  a-grid means layer centers
c  c-grid means layer interfaces
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension h(npt,nz), f(npt,nz), df(npt,nz)
      dimension nzi(npt)

c.....    nzi  : number of layers
c.....    h    : layer depth
c.....    f    : quantity to be differentiated
c.....    df   : vertical derivative of tracer 
c
      do i = 1, npt
         nzb = nzi(i)
         do k=  2, nzb -1
            df(i,k) = (f(i,k-1) - f(i,k)) / h(i,k)
         enddo
         df(i,1)   = (0. - f(i,1)) / h(i,1)
         df(i,nzb) = (f(i,nzb-1) - 0.) / h(i,nzb)
      enddo
      
      return
      end


c     ------------------------------------------------------------------
      subroutine ddivs (npt,uc,vc,emx,emy,emxy,w,fhd,lxxk,lyyk,lxyk,lyxk,
     *       snxk,snyk,isyk,isk,tp,mbc,lpbcwk,lpbcek)
csenq ------------------------------------------------------------------
c     compute the divergence (fhd) for all layers and put the Sum in w(1,nz).
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch

      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz)
      dimension uc(npt,nz),vc(npt,nz),emx(npt),emy(npt),emxy(npt),w(npt,nz),
     *     fhd(npt,nz), tp(npt,4)
c
c     set boundary condition flag based on whether interior corners are
c     treated as boundaries.  see bcset and dfdx.
c
      nbu = 0
      nbv = 0
      if(mbc.eq.1 .or. mbc.eq.4) nbu = 1
      if(mbc.eq.1 .or. mbc.eq.3) nbv = 1


c........compute d(hv)/dy & d(hu)/dx..
      nxk = nbxk(1)
      nyk = nbyk(1)
      nck = ncsk(1)
      npbk = npbck(1)
      call dfdx1(uc,tp(1,3),npt,nbu,nxk,nyk,nck,lxxk,lyxk,
     *     snxk,npbk,lpbcwk,lpbcek)
      call dfdy1(vc,tp(1,4),npt,nbv,nyk,nxk,nck,
     *     lyyk,lxyk,snyk,isyk)

      if (mgrid .ne. 2) then
         do i = 1, npt
            fhd(i,1) = emx(i)*tp(i,3) + emy(i)*tp(i,4)
         enddo
      else
         do i = 1, npt
            fhd(i,1) = emx(i)*tp(i,3) + emy(i)*tp(i,4) + emxy(i)*vc(i,1)
         enddo
      endif
      
      do k = 2, nz
         npk = nptk(k)
c........mud points have zero transport:
         call zero_em (npt, tp)
         call zero_em (npt, tp(1,2))
         do j = 1, npk
            i = isk(j,k)
            tp(i,1) = uc(i,k)
            tp(i,2) = vc(i,k)
         enddo
         call dfdx1(tp,tp(1,3),npt,nbu,nxk,nyk,nck,lxxk,lyxk,
     *       snxk,npbk,lpbcwk,lpbcek)
         call dfdy1(tp(1,2),tp(1,4),npt,nbv,nyk,nxk,nck,
     *        lyyk,lxyk,snyk,isyk)

c........now multiply by the appropriate scale factors to find divergence.
c........div(u) = (1/mx)*(du/dx) + (1/my)*(dv/dy) + myx*u + mxy*v
c........we also accumulate the sum of layer divergences in w(nz)
         if (mgrid .ne. 2) then
            do i = 1, npt
               fhd(i,k) = emx(i)*tp(i,3) + emy(i)*tp(i,4)
            enddo
         else
            do i = 1, npt
               fhd(i,k) = emx(i)*tp(i,3) + emy(i)*tp(i,4) + 
     *                    emxy(i)*tp(i,2) 
            enddo
         endif
      enddo

      return
      end


dyn_dyice.f/    842884175   1572  1572  100444  7999      `
       subroutine ice_force(nx,ny,mx,my,fx,fy,uice,vice,hice,qice,
     *                   uw,vw,uo,vo,lsm,dyd,dxd,slat)
c
c  compute forcing terms for ice momentum equation
c  ice pressure and air/water drag
c  based on Hibler 1989 rheology
c
c  input:
c  hice =  ice thickness   [m]
c  qice = ice concentration (0-1) 
c  uw,vw =   wind velocity [m/s]
c  uo,vo = water velocity [m/s]
c  uice,vice  = ice velocity [m/s]
c  lsm  = land/sea mask (1=land, 0=sea)
c  slat = southern latitude of input grid, in degrees (e.g. -30.)
c  dxd  = grid spacing in degrees longitude.  dxd(i) equals the distance from
c         the longitude at i-1 to the longitude at i which allows for
c         uneven grid spacing.
c  dyd  = grid spacing in degrees latitude.  dyd(j) equals the distance from
c         the latitude at j to the latitude at j+1 which allows for
c         uneven grid spacing.
c  nx   = number of x grid points <= mx
c  ny   = number of y grid points <= my
c  mx   = x grid dimension
c  my   = y grid dimension                                                     
c
c  output:
c  fx,fy   =  forcing for momentum equation [m^2/s^2]
c
c
c  d(hu)/dt = div(k*grad(hu)) - f x (hu) - gh*grad(H) + [fx,fy]
c
c  where [fx,fy] = tau_a/rhoice + tau_o/rhoice + F_ice/rhoice
c
c  Martin Visbeck, Sept, 1996,  version 1.0
c
c  you can not have ice at the very last grid point
c  it wants to be land or water
c
c
c    grids
c                 i     i    (i+1) 
c                 |     |     |
c     +     *     +     *     +  - (j+1)     + ( A - grid )  U,V,hice,qice
c                                            * ( i - grid )  dudxi,..
c     o           o           o  - j         o ( j - grid )  dudxj,..
c
c     +     *     +     *     +  - j
c
c     o           o           o
c
c     +     *     +     *     +  - (j-1)
c
c


       include 'icedyn.h'

       parameter (rhoa=1.3, rhow=1028., rhoi=900.) 
       parameter (mxx=10, myy=10, nicemax= mxx*myy)

       dimension fx(mx,my),fy(mx,my)
       dimension uice(mx,my),vice(mx,my)
       dimension hice(mx,my),qice(mx,my)
       dimension uw(mx,my),vw(mx,my),uo(mx,my),vo(mx,my)
       dimension lsm(mx,my),dyd(my),dxd(mx,my)
       dimension ni(nicemax),nj(nicemax),nicem(mxx,myy)
       dimension fv1(nicemax),fv2(nicemax),fv3(nicemax),fv4(nicemax)
       dimension dx(mxx,myy),dy(myy),ism(mxx,myy),rlat(myy)
c
c   coefficients for drags
c 
       cws=dyice_ciw*sin(dyice_alpiw)*rhow
       cwc=dyice_ciw*cos(dyice_alpiw)*rhow
       cas=dyice_cai*sin(dyice_alpai)*rhoa
       cac=dyice_cai*cos(dyice_alpai)*rhoa
c
c   coefficients for strain rates
c
       e2=dyice_e*dyice_e
       e2i=1/e2
       e2fp=(e2+1)/e2
       e2fm=(e2-1)/e2
c
c  inverse ice density
c 
       rhoii=1./rhoi

c  determine grid spacing in m and find ice points

      conv=2.*3.14/360.
      radius=6.37e+6
      j=1
      dy(j)=radius*dyd(j)*conv
      rlat(j)=slat*conv
      do 1 i=1,nx
       dx(i,j)=conv*radius*cos(rlat)*dxd(i,j)
       if (lsm(i,j).eq.1) then
         ism(i,j)=1
         nicem(i,j)=nicemax
         uice(i,j)=0.
         vice(i,j)=0.
       endif
 1    continue
      do 2 j=2,ny
       dy(j)=conv*radius*dyd(j)
       rlat(j)=rlat(j-1)+dyd(j)*conv
       do 2 i=1,nx
        if (lsm(i,j).eq.1) then
          ism(i,j)=1
          nicem(i,j)=nicemax
          uice(i,j)=0.
          vice(i,j)=0.
        else
          ism(i,j)=0
        endif
      dx(i,j)=conv*radius*cos(rlat)*dxd(i,j)
 2    continue
                                          


c   first make up index for ice points or near ice points 
       nice=0

       do i=2,nx-1
        do j=2,ny-1
          if (hice(i,j)+hice(i,j+1)+hice(i+1,j).ge.hicemin) then
            nice=nice+1
            ni(nice)=i
            nj(nice)=j
            nicem(i,j)=nice
          else
            nicem(i,j)=nicemax
          endif
          if (hice(i,j).ge.hicemin) then
            ism(i,j)=1
          else
           uice(i,j)=0.
           vice(i,j)=0.
          endif
        enddo
       enddo

c    loop only over ice points

       do n=1,nice
          i=ni(n)
          j=nj(n)

c    ensure free slip at ice/ocean point and no slip at ice/land point
          ioki=ism(i,j)*ism(i+1,j)
          iokji=ism(i-1,j)*ism(i+1,j)*ism(i-1,j+1)*ism(i+1,j+1)
          iokj=ism(i,j)*ism(i,j+1)
          iokij=ism(i,j-1)*ism(i,j+1)*ism(i+1,j-1)*ism(i+1,j+1)
          
c    ice thickness, concentration and pressure at i, j grid points

           hicei = 0.5*(hice(i,j)+hice(i+1,j))
           hicej = 0.5*(hice(i,j)+hice(i,j+1))
           qicei = 0.5*(qice(i,j)+qice(i+1,j))
           qicej = 0.5*(qice(i,j)+qice(i,j+1))
           picei = dyice_p * hicei * exp(-dyice_c*(1-qicei))
           picej = dyice_p * hicej * exp(-dyice_c*(1-qicej))

c    shear terms at i and j grid points

           dudxi=(uice(i+1,j)-uice(i,j))/dx(i+1,j)*ioki
           dvdxi=(vice(i+1,j)-vice(i,j))/dx(i+1,j)*ioki
           dudyj=(uice(i,j+1)-uice(i,j))/dy(j)*iokj
           dvdyj=(vice(i,j+1)-vice(i,j))/dy(j)*iokj

           dudxj=((uice(i+1,j)-uice(i-1,j))/(dx(i+1,j)+dx(i,j))
     *       +(uice(i+1,j+1)-uice(i-1,j+1))/(dx(i+1,j+1)+dx(i,j+1)))
     *        *0.5*iokji
           dvdxj=((vice(i+1,j)-vice(i-1,j))/(dx(i+1,j)+dx(i,j))
     *       +(vice(i+1,j+1)-vice(i-1,j+1))/(dx(i+1,j+1)+dx(i,j+1)))
     *        *0.5*iokji
           dudyi=(uice(i,j+1)-uice(i,j-1)+
     *       uice(i+1,j+1)-uice(i+1,j-1))/(dy(j-1)+dy(j))*0.5*iokij
           dvdyi=(vice(i,j+1)-vice(i,j-1)+
     *       vice(i+1,j+1)-vice(i+1,j-1))/(dy(j-1)+dy(j))*0.5*iokij
           write(*,*)i,j,ioki,iokji,iokj,iokij
           write(*,*)i,j,dudxi,dvdxi,dudyj,dvdyj
           write(*,*)i,j,dudxj,dvdxj,dudyi,dvdyi
        

c    strain rate square str2

           str2i= (dudxi*dudxi + dvdyi*dvdyi)*e2fp + 
     *       (dudyi + dvdxi)**2 *e2i + 2*(dudxi*dvdyi)*e2fm       
           str2j= (dudxj*dudxj + dvdyj*dvdyj)*e2fp + 
     *       (dudyj + dvdxj)**2 *e2i + 2*(dudxj*dvdyj)*e2fm       

c    bulk viscosity
           vibi= picei/(2 * max(dyice_emin,sqrt(str2i)))
           vibj= picej/(2 * max(dyice_emin,sqrt(str2j)))

c    shear viscosity
           visi = vibi * e2i
           visj = vibj * e2i


c    stress tensor fv1,fv3 on i grid, fv2 and fv4 on j grid
c
c                | fv1      fv2 |
c       tensor = |              |
c                | fv3      fv4 |
c

           fv1(n) = (vibi+visi)*dudxi+(vibi-visi)*dvdyi-picei/2
           fv2(n) = visj*(dudyj + dvdxj)
           fv3(n) = visi*(dudyi + dvdxi)
           fv4(n) = (vibj+visj)*dvdyj+(vibj-visj)*dudxj-picej/2
       enddo    
          
c
c   loop only over ice points to compute ice stress divergence...
c
c       open(2,file='icet.out',form='formatted',status='unknown')
c
       do n=1,nice
          i=ni(n)
          j=nj(n)
c          write(2,*)i,j,fv1(n),fv2(n),fv3(n),fv4(n) 
c
c  compute forcing only at points with ice
c
         if (hice(i,j).gt.hicemin) then

          nim=nicem(i-1,j)
          njm=nicem(i,j-1)
          fxsd=(fv1(n)-fv1(nim))/(0.5*(dx(i+1,j)+dx(i,j)))
     *            + (fv2(n)-fv2(njm))/(0.5*(dy(j)+dy(j-1)))
          fysd=(fv3(n)-fv3(nim))/(0.5*(dx(i+1,j)+dx(i,j)))
     *            + (fv4(n)-fv4(njm))/(0.5*(dy(j)+dy(j-1)))


  
c
c   get atmos ice drag
c
       
         if (rlat(j).gt.0) then
          casf=cas
          cwsf=cws
         else
c  ..... southern hemisphere
          casf=-cas
          cwsf=-cws
         endif
  
c  wind speed

         sw=sqrt(uw(i,j)**2+vw(i,j)**2) 

         fxai=sw*(uw(i,j)*cac-vw(i,j)*casf)
         fyai=sw*(vw(i,j)*cac-uw(i,j)*casf)

c
c    water-ice drag
c
         sw=sqrt((uo(i,j)-uice(i,j))**2+(vo(i,j)-vice(i,j))**2) 
c        water speed

         fxwi=sw*((uo(i,j)-uice(i,j))*cwc-(vo(i,j)-vice(i,j))*cwsf)
         fywi=sw*((vo(i,j)-vice(i,j))*cwc-(uo(i,j)-uice(i,j))*cwsf)

c 
c sum forcing terms up 
c
         fx(i,j)=rhoii*(fxsd+fxai+fxwi)
         fy(i,j)=rhoii*(fysd+fyai+fywi)

       endif

       enddo

       return
       end


dyn_filt.f/     842294936   1572  1572  100444  21967     `
      subroutine shap_indx(npt,nxp,nyp,mask,isx,nfxk,nfpxk,nfyk,ifx,ifpx,ify)
c-------------------------------------------------------------------------

c     nfx     : number of contiguous latitudinal segments 
c     ifx(1,i): starting point (x-compressed index) of i'th segment  
c     ifx(2,i): length of i-th segment
c     ifx(3,i): highest order filter used in i'th segment

c     nfpx    : number of segments with periodic overlap
c     ifx(1,i): starting point western portion of segment 
c     ifx(2,i): length of western portion of segment
c     ifx(3,i): starting point eastern portion of segment 
c     ifx(4,i): length of eastern portion of segment
c     ifx(5,i): highest order filter used in segment

c     nfy     : number of contiguous longitudinal segments 
c     ify(1,j): starting point (y-compressed index) of j'th segment
c     ify(2,j): length of j'th segment
c     ify(3,j): highest order filter used in j'th segment

      include "comm_new.h"
      include 'comm_para.h'
      dimension mask(nxp,1),isx(1),ifx(3,1),ifpx(5,1),ify(3,1)
      logical prev, curr, peri, ZER
      common /shap_c25/ cs25(10), ZER, s_coef
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      do i = 1, MAXFO
         cs25(i) = 1./(4.**i)
      enddo
 
      nfxk  = 0
      nfpxk = 0
      do irow = 1, nyp

         ista = 1
         prev = (mask(1, irow) .eq. 0)
         peri = (.not. prev) .and. (iglob .ne. 0)  

         do icol = 2, nxp
            
            curr = (mask(icol,irow) .eq. 0)
            if (curr .ne. prev) then
                if (peri .and. ista .eq. 1) then
                  nfpxk = nfpxk + 1
                  ifpx(1,nfpxk) = mask(1,irow)
                  ifpx(2,nfpxk) = icol - 1
               elseif (curr) then
                  nfxk = nfxk + 1
                  ifx(1,nfxk) = mask(ista,irow)
                  ifx(2,nfxk) = icol-ista
                  ifx(3,nfxk) = min((icol-ista-1)/2,MAXFO)
               endif
               ista = icol
               prev = curr
            endif
         enddo
            
         if (.not. curr) then
            if (peri) then
               if (ista .eq. 1) then
                  nfpxk = nfpxk + 1
                  ifpx(1,nfpxk) = mask(1,irow)
                  ifpx(2,nfpxk) = nxp
                  ifpx(3,nfpxk) = 0
                  ifpx(4,nfpxk) = 0
                  ifpx(5,nfpxk) = MAXFO
               else
                  ifpx(3,nfpxk) = mask(ista,irow)
                  ifpx(4,nfpxk) = mask(nxp,irow) - mask(ista,irow) + 1
                  ifpx(5,nfpxk) = min((ifpx(2,nfpxk)+ifpx(4,nfpxk)-1)/2,MAXFO)
               endif
            else
               nfxk = nfxk + 1
               ifx(1,nfxk) = mask(ista,irow)
               ifx(2,nfxk) = nxp-ista+1
               ifx(3,nfxk) = min((nxp-ista)/2,MAXFO)
            endif
         endif
      enddo

      nfyk  = 0
      do icol = 1, nxp

         jsta = 1
         prev = (mask(icol, 1) .eq. 0)
         do irow = 2, nyp
            
            curr = (mask(icol,irow) .eq. 0)
            if (curr .ne. prev) then
               if (curr) then
                  nfyk = nfyk + 1
                  ify(1,nfyk) = isx(mask(icol,jsta))
                  ify(2,nfyk) = irow-jsta
                  ify(3,nfyk) = min((irow-jsta-1)/2,MAXFO)
               endif
               jsta = irow
               prev = curr
            endif
         enddo
         if (.not. curr) then
            nfyk = nfyk + 1
            ify(1,nfyk) = isx(mask(icol,jsta))
            ify(2,nfyk) = nyp-jsta+1
            ify(3,nfyk) = min((nyp-jsta)/2,MAXFO)
         endif
      enddo

      return
      end

c-----------------------------------------------------------------------
      subroutine shap_vec(nstep,npt,nz,uc,vc,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
c-----------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      dimension uc(npt,1),vc(npt,1),tp(1)
      dimension lxxk(MXBDY,nz),lyxk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *          ifxk(9*MAXSID,nz), ifpxk(5*MAXSID,nz), ifyk(9*MAXSID,nz)
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +         ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      logical NOSLIP
      common /new_shap/nordu,nshapu,mshapu,dshapu, nordh,nshaph,mshaph,dshaph
      common/param0/iyear,iday,isec,delt,ncyc,mbc,nonlin,label(20),
     +              itherm,mlc,limp
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      external shap_1drn, shap_1dro

      if (mshapu .eq. 0) return

      if (nstep.eq.0 .or. (nshapu.ne.0 .and. mod(nstep,nshapu).eq.0)) then
         NOSLIP = (mbc .eq. 1)
         do k = 1, nz
            npk = nptk(k) 
            nbx = nbxk(k) 
            nby = nbyk(k) 
            nfx = nfxk(k) 
            nfpx = nfpxk(k) 
            nfy = nfyk(k) 
            if     (mshapu .eq. 1) then
c........use NEW reduce order filter near BC & in NARROW passages: 
               call shap_2d (nordu,.true.,.true.,NOSLIP,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1drn,dshapu)
               call shap_2d (nordu,.true.,NOSLIP,.true., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1drn,dshapu)
            elseif (mshapu .eq. 2) then
c........use NEW reduce order filter near BC only:
               call shap_2d (nordu,.false.,.true.,NOSLIP,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1drn,dshapu)
               call shap_2d (nordu,.false.,NOSLIP,.true., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1drn,dshapu)
            elseif (mshapu .eq. 3) then
c........use OLD reduce order filter near BC & in NARROW passages: 
               call shap_2d (nordu,.true.,.true.,NOSLIP,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1dro,dshapu)
               call shap_2d (nordu,.true.,NOSLIP,.true., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1dro,dshapu)
            elseif (mshapu .eq. 4) then
c........use OLD reduce order filter near BC only:
               call shap_2d (nordu,.false.,.true.,NOSLIP,npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),uc(1,k),tp,shap_1do,dshapu)
               call shap_2d (nordu,.false.,NOSLIP,.true., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),vc(1,k),tp,shap_1do,dshapu)
            endif
         enddo
      endif
            
      return
      end

c-----------------------------------------------------------------------
      subroutine shap_scl(nstep,npt,nz,tem,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
c-----------------------------------------------------------------------
 
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      dimension tem(npt,nz), tp(1)
      dimension lxxk(MXBDY,nz),lyxk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *          ifxk(9*MAXSID,nz), ifpxk(5*MAXSID,nz), ifyk(9*MAXSID,nz)

      common /new_shap/nordu,nshapu,mshapu,dshapu, nordh,nshaph,mshaph,dshaph
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +         ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      external shap_1dco, shap_1dcn

      if (mshaph .eq. 0) return

      if (nstep.eq.0 .or. (nshaph.ne.0 .and. mod(nstep,nshaph).eq.0))  then
         do k = 1, nz
            npk = nptk(k) 
            nbx = nbxk(k) 
            nby = nbyk(k) 
            nfx = nfxk(k) 
            nfpx = nfpxk(k) 
            nfy = nfyk(k) 
            if     (mshaph .eq. 1) then
c........use NEW conservative filter: 
               call shap_2d (nordh, .false., .false.,.false., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            elseif (mshaph .eq. 2) then
c........use NEW conservative filter & REDUCE order in NARROW passages: 
               call shap_2d (nordh, .true., .false.,.false., npk, 
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            elseif (mshaph .eq. 3) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordh, 3, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dco,dshaph)
            elseif (mshaph .eq. 5) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordh, 3, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            elseif (mshaph .eq. 6) then
c........use OLD conservative filter; REDUCE or IGNORE in NARROW passages:  
               call shap_2dlim (nordh, 4, .false.,.false.,npk,
     *              lxxk(1,k),lyxk(1,k),isyk(1,k),isk(1,k),ifxk(1,k),
     *              ifpxk(1,k),ifyk(1,k),tem(1,k),tp,shap_1dcn,dshaph)
            endif
         enddo
      endif
         

      return
      end

c--------------------------------------------------------------------------
      subroutine shap_2d (nord,REDUC,SETX,SETY,npt,lxx,lyx,isy,isk,
     *                     ifx,ifpx,ify, aa,abc,filter,scoef)
c--------------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension lxx(1),lyx(1),isy(1),isk(1), aa(1), bb(1), cc(1), abc(npt,1)
      dimension ifx(3,1), ifpx(5,1), ify(3,1) 
      logical SETX, SETY, ZER, REDUC 
      pointer (pbb, bb), (pcc, cc)
      external filter

      common /shap_c25/ cs25(10), ZER, s_coef
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      s_coef = scoef

c sizeof(abc) = 3*npt

      pbb = loc(abc(1,1))
      pcc = loc(abc(1,2))

c.......apply Shapiro filter in X direction
      do i = 1, npt
         bb(i) = aa(isk(i))
      enddo

      ZER = SETX   ! used only if filter = shap_1do
      nshap = MAXFO
      do k = 1, nfx
         if (REDUC) nshap = min(nord, ifx(3,k))
         call filter (nshap, ifx(2,k), bb(ifx(1,k)), cc)
      enddo

      do k = 1, nfpx
         if (REDUC) nshap = min(nord, ifpx(5,k))
         if (ifpx(4,k) .eq. 0) then
            call shap_1dp0 (nshap, ifpx(2,k), bb(ifpx(1,k)), cc)
         else
            call shap_1dper (nshap, ifpx(1,k), bb, cc, filter)
         endif
      enddo

      do i = 1, npt
         cc(isk(i)) = bb(i)
      enddo
      
      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo
      
c.......apply Shapiro filter in Y direction
      do i = 1, npt
         bb(i) = aa(isy(i))
      enddo

      ZER = SETY 
      do k = 1, nfy
         if (REDUC) nshap = min(nord, ify(3,k))
         call filter (nshap, ify(2,k), bb(ify(1,k)), cc)
      enddo

      do i = 1, npt
         cc(isy(i)) = bb(i)
      enddo

      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo

      return
      end

c--------------------------------------------------------------------------
      subroutine shap_2dlim (nord,key,SETX,SETY,npt,lxx,lyx,isy,isk,
     *                       ifx,ifpx,ify, aa,abc,filter,scoef)
c--------------------------------------------------------------------------
c.....reduces order for all points on short segments
c                 length=4   -> nshap = 1
c                 length=5,6 -> nshap = min(2,nord)
c                 length=7,8 -> nshap = min(3,nord)
c                  etc.
c.....but if nshap <= LIM_SHAP, then DON'T FILTER segment at all

      implicit real(a-h,o-z),integer(i-n)
      dimension lxx(1),lyx(1),isy(1),isk(1), aa(1), bb(1), cc(1), abc(npt,1)
      dimension ifx(3,1), ifpx(5,1), ify(3,1)
      logical SETX, SETY, ZER, REDUC 
      pointer (pbb, bb), (pcc, cc)
      external filter

      common /shap_c25/ cs25(10), ZER, s_coef
      common /new_filt/  MAXFO, nbx, nby, nfx, nfpx, nfy

      s_coef = scoef
      LIM_SHAP = key - 2

c sizeof(abc) = 3*npt

      pbb = loc(abc(1,1))
      pcc = loc(abc(1,2))

c.....use a reduced order filter in a narrow passages.
c
c.......apply Shapiro filter in X direction
      do i = 1, npt
         bb(i) = aa(isk(i))
      enddo

      ZER = SETX
      do k = 1, nfx
         nshap = min(nord, ifx(3,k))
         if (nshap .gt. LIM_SHAP) then
            call filter (nshap, ifx(2,k), bb(ifx(1,k)), cc)
         else
            call zero_em (ifx(2,k), bb(ifx(1,k)))
         endif
      enddo

      do k = 1, nfpx
         nshap = min(nord, ifpx(5,k))
         if (nshap .gt. LIM_SHAP) then
            if (ifpx(4,k) .eq. 0) then
               call shap_1dp0 (nshap, ifpx(2,k), bb(ifpx(1,k)), cc)
            else
               call shap_1dper (nshap, ifpx(1,k), bb, cc, filter)
            endif
         else
            call zero_em (ifpx(2,k), bb(ifpx(1,k)))
            call zero_em (ifpx(4,k), bb(ifpx(3,k)))
         endif
      enddo

      do i = 1, npt
         cc(isk(i)) = bb(i)
      enddo

      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo
      
c.......apply Shapiro filter in Y direction

      do i = 1, npt
         bb(i) = aa(isy(i))
      enddo

      ZER = SETY

      do k = 1, nfy
         nshap = min(nord, ify(3,k))
         if (nshap .gt. LIM_SHAP) then 
            call filter (nshap, ify(2,k), bb(ify(1,k)), cc)
         else
            call zero_em (ify(2,k), bb(ify(1,k)))
         endif
      enddo

      do i = 1, npt
         cc(isy(i)) = bb(i)
      enddo

      if (SETX) then
         do i = 1, nbx
            cc(lxx(i)) = 0.
         enddo
      endif
      if (SETY) then
         do i = 1, nby
            cc(lyx(i)) = 0.
         enddo
      endif

      do j = 1, npt
         i = isk(j)
         aa(i) = aa(i) - cc(i)
      enddo

      return
      end
      
      subroutine shap_1drn (nshap, nn, f, tmp)
c----------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), cc(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pcc, cc), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef
      
      paa = loc(f(1))
      pbb = loc(tmp(1))
      pcc = loc(tmp(nn+1))

      do n = 1, nshap
         const = s_coef*cs25(n)
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         if (n .eq. 1) then
            if (ZER) then
               aa(1)  = 0.
               aa(nn) = 0.
            else
               aa(1)  = -aa(2)
               aa(nn) = -aa(nn-1)
            endif
         elseif (.not. ZER) then
            aa(n)      = -aa(n+1)
            aa(nn-n+1) = -aa(nn-n)
         endif

         cc(n)      = const*aa(n)
         cc(nn-n+1) = const*aa(nn-n+1)
      enddo

      do i = nshap+1, nn-nshap
         f(i) = const*aa(i)
      enddo

      do i = 1, nshap
         f(i)      = cc(i)
         f(nn-i+1) = cc(nn-i+1)
      enddo

      return
      end

      subroutine shap_1dro (nshap, nn, f, tmp)
c----------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), cc(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pcc, cc), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef
      
      paa = loc(f(1))
      pbb = loc(tmp(1))
      pcc = loc(tmp(nn+1))

      do n = 1, nshap
         const = s_coef*cs25(n)
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         if (n .eq. 1) then
            if (ZER) then
               aa(1)  = 0.
               aa(nn) = 0.
            else
               aa(1)  = bb(1)  - bb(2) 
               aa(nn) = bb(nn) - bb(nn-1)
            endif
         endif

         cc(n)      = const*aa(n)
         cc(nn-n+1) = const*aa(nn-n+1)
      enddo

      do i = nshap+1, nn-nshap
         f(i) = const*aa(i)
      enddo

      do i = 1, nshap
         f(i)      = cc(i)
         f(nn-i+1) = cc(nn-i+1)
      enddo

      return
      end

      subroutine shap_1dper (nshap, id, f, tmp, filter)
c------------------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension id(4), f(1), tmp(1), aa(1), bb(1)
      pointer (paa, aa), (pbb, bb)
      external filter

      i1 = id(1)
      n1 = id(2)

      i2 = id(3)
      n2 = id(4)
      n12 = n1 + n2

      paa = loc(f(i2))
      do i = 1, n2
         tmp(i) = aa(i) 
      enddo
      paa = loc(f(i1))
      k = n2
      do i = 1, n1
         k = k + 1
         tmp(k) = aa(i) 
      enddo
      
      call filter (nshap, n12, tmp, tmp(n12+1))
      
      k = n2
      do i = 1, n1
         k = k + 1
         aa(i) = tmp(k) 
      enddo
      paa = loc(f(i2))
      do i = 1, n2
         aa(i) = tmp(i) 
      enddo

      return
      end

      subroutine shap_1dcn (nshap, nn, f, tmp)
c---------------------------------------------      
c suppose to be an old key=6 case
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         aa(1)  = -aa(2)
         aa(nn) = -aa(nn-1)
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end

      subroutine shap_1dco (nshap, nn, f, tmp)
c---------------------------------------------      
c suppose to be an old key=6 case
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         aa(1)  = bb(1)  - bb(2)
         aa(nn) = bb(nn) - bb(nn-1)
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end

      subroutine shap_1dp0 (nshap, nn, f, tmp)
c---------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f1 = bb(1)
         f2 = bb(2)
         f0 = f1
         fp = f2
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
         aa(1)  = (f1 - f2) + (f1 - fp)
         aa(nn) = (fp - f1) + (fp - f0)
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end

      subroutine shap_1dc (nshap, nn, f, tmp)
c---------------------------------------------      
      implicit real(a-h,o-z),integer(i-n)
      dimension f(1), tmp(1), aa(1), bb(1), ab(1)
      pointer (paa, aa), (pbb, bb), (pab, ab)
      logical ZER

      common /shap_c25/ cs25(10), ZER, s_coef

      paa = loc(f(1))
      pbb = loc(tmp(1))

      do n = 1, nshap
         pab = paa
         paa = pbb
         pbb = pab
         
         f0 = bb(1)
         fp = bb(2)
         do i = 2, nn-1
            fm = f0
            f0 = fp
            fp = bb(i+1)
            aa(i) = (f0 - fp) + (f0 - fm)
         enddo
      enddo

      al = -aa(1+nshap)
      ar = -aa(nn-nshap)
      do i = nshap, 1, -1 
         aa(i)      = al
         aa(nn-i+1) = ar
         al = -al
         ar = -ar
      enddo

      const = s_coef*cs25(nshap)
      do i = 1, nn
         f(i) = const * aa(i)
      enddo

      return
      end


dyn_forc.f/     847474357   1572  1572  100444  70652     `
c     ------------------------------------------------
      subroutine depth_init (npt, zin)
c     ------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_data.h'
      include 'comm_new.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      dimension zin(1)

      if     (initb .eq. 0) then
c.....Constant Depth (Flat Bottom)
         dep_max = zin(nz+1)
         call afill(npt, dept, dep_max)
         dep_min = dep_max
      elseif (initb .eq. 1) then
c.....Read Bathymetry Data From a File

         call odb_open(idf_dp, fbdep(1:n_dep), 0)

         call data_on_model_grid(idf_dp, lret, 'bath') 

         call read_zt (idf_dp, lret, npt, 1, 1, 'bath', tp, dept)

      elseif (initb .eq. 2) then
         iseed = 10001
         dept(1) = 50 + zin(nz+1)*ran(iseed)
         do i = 2, npt
            dept(i) = 50 +  zin(nz+1)*ran(iseed)
         enddo

         do i = 1, npt
            dept(i) = max(dept(i),zin(1))
         enddo

      elseif (initb .eq. 3) then
c        ramp

         depmin = (zin(initb-2) + zin(initb-1))/2.
         depmax = zin(nz+1)
         x1 = xm(1)
         xn = xm(nxp)
         xs = xn-x1
         do i = 1, nxp
            tp(i) = depmin + (xm(i) - x1)*(depmax-depmin)/xs
         enddo
         y1 = ym(1)
         yn = ym(nyp)
         ys = yn-y1
         do j = 1, nyp
            tp(j+nxp) = depmin + (ym(j) - y1)*(depmax-depmin)/ys
         enddo

         do k = 1, npt
            j = (iox(k)-1)/nxp + 1
            i = iox(k) - (j-1)*nxp
            dept(k) = depmax
            if (i.ge.i_ridge_min.and.i.le.i_ridge_max) 
c     *                       dept(k) = (tp(i)+tp(j+nxp))/2.
     *                       dept(k) = tp(j+nxp)
         enddo

      elseif (initb .eq. 4) then
c        ridge

         depmin = (zin(initb-2) + zin(initb-1))/2.
         depmax = zin(nz+1)
         x1 = xm(1)
         xn = xm(nxp)
         xs = xn-x1
         do i = 1, nxp
            tp(i) = depmin + (xm(i) - x1)*(depmax-depmin)/xs
         enddo
         y1 = ym(1)
         yn = ym(nyp)
         ys = yn-y1
         do j = 1, nyp
            tp(j+nxp) = depmin + (ym(j) - y1)*(depmax-depmin)/ys
         enddo

         do k = 1, npt
            j = (iox(k)-1)/nxp + 1
            i = iox(k) - (j-1)*nxp
            dept(k) = depmax
            if (i.ge.i_ridge_min.and.i.le.i_ridge_max) 
c     *                       dept(k) = (tp(i)+tp(j+nxp))/2.
     *                       dept(k) = tp(j+nxp)
         enddo

      endif

      dept(1) = max(dep_min,dept(1))
      do i = 2, npt
         dept(i) = max(dep_min,dept(i))
      enddo

      dep_min = dept(1)
      dep_max = dept(1)
      do i = 2, npt
         dep_max = max(dep_max, dept(i))
         dep_min = min(dep_min, dept(i))
      enddo

      return
      end

c     --------------------------------------------------------------------
      subroutine clim_init(npt,nstart,h0,sigma,dzin,hmf,
     *                     hclf,tclf,sclf,dclf,psif,tpf,nsponge,lsponge)
c     --------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_data.h'
      dimension h0(1),hmf(npt,nz),hclf(npt,nz,1),dclf(npt,nz),dzin(nz+1),
     *          tclf(npt,nz,1),sclf(npt,nz,1),tpf(npt,1),ind3(3),sigma(nz)
     *          ,lsponge(nsponge), psif(npt,1)
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
c
      do k = nsig+1, nz
         do i = 1, npt
            hclf(i,k,1) = hmf(i,k)
         enddo
      enddo

      if     (icl_h .eq. 0) then
         do k = 1, nsig
            do i = 1, npt
               hclf(i,k,1) = hmf(i,k)
            enddo
         enddo

      elseif (icl_h .eq. 1) then
c........H: sigma structure between Mixed Layer & Thermocline - Static:
         call odb_open(idf_hcl, fbhcl(1:n_hcl), 0)
         call data_on_model_grid(idf_hcl, lclm, 'mltc')

         if (icl_htop .eq. 1) 
     *   call read_zt (idf_hcl,lclm,npt, 1,1, 'mltc', tpf, hclf(1,1,1))

         if (icl_htop .eq. 0) call afill (npt, hclf, h0(1))

         sigk = sigma(3)
         do i = 1, npt
            hclf(i,2,1) = 0.5*hclf(i,1,1) + sigk*(z_begin - 1.5*hclf(i,1,1))
         enddo
         do k = 3, nsig - 1
            sigkp = sigma(k+1)
            do i = 1, npt
               hclf(i,k,1) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,1))
            enddo
            sigk = sigkp
         enddo
         k = nsig
         do i = 1, npt
            hclf(i,k,1) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,1))
         enddo

      elseif (icl_h .eq. 2) then
c........H: sigma structure between Mixed Layer & Thermocline - Dynamic
         call odb_open(idf_hcl, fbhcl(1:n_hcl), 0)
         call data_on_model_grid(idf_hcl, lclm, 'mltc')

         call odb_rddm(idf_hcl, 'T', ntclm)
         call mem_alloc(p_tclm, ntclm, 2, 'tclm')
         call odb_rdgr(idf_hcl, 'T', ntclm, tclm)

         call it_catch (ntclm, tclm, nstart, it1, it2, clm_tscl)
         iclm = it2

         if (icl_htop .eq. 1) then
            call read_zt (idf_hcl, lclm,npt, 1, it1, 'mltc', tpf, hclf(1,1,1))
            call read_zt (idf_hcl, lclm,npt, 1, it2, 'mltc', tpf, hclf(1,1,2))
         endif

         if (icl_htop .eq. 0) then
            call afill (npt, hclf(1,1,1), h0(1))
            call afill (npt, hclf(1,1,2), h0(1))
         endif

         sigk = sigma(3)
         do i = 1, npt
            hclf(i,2,1) = 0.5*hclf(i,1,1) + sigk*(z_begin - 1.5*hclf(i,1,1))
            hclf(i,2,2) = 0.5*hclf(i,1,2) + sigk*(z_begin - 1.5*hclf(i,1,2))
         enddo
         do k = 3, nsig - 1
            sigkp = sigma(k+1)
            do i = 1, npt
               hclf(i,k,1) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,1))
               hclf(i,k,2) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,2))
            enddo
            sigk = sigkp
         enddo
         k = nsig
         do i = 1, npt
            hclf(i,k,1) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,1))
            hclf(i,k,2) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,2))
         enddo
      endif

      if (icl_psi .eq. 1) then
         call odb_open(idf_psi, fbpsi(1:n_psi), 0)
         call data_on_model_grid(idf_psi, lpsi, 'psi')

         call read_zt (idf_psi,lpsi,npt, 1,1, 'psi', tpf, psif(1,1))

      elseif (icl_psi .eq. 2) then

         call odb_open(idf_psi, fbpsi(1:n_psi), 0)
         call data_on_model_grid(idf_psi, lpsi, 'psi')

         call odb_rddm(idf_psi, 'T', ntpsi)
         call mem_alloc(p_tpsi, ntpsi, 2, 'psi')
         call odb_rdgr(idf_psi, 'T', ntpsi, tpsi)

         call it_catch (ntpsi, tpsi, nstart, it1, it2, psi_tscl)
         ipsi = it2

         call read_zt (idf_psi, lpsi,npt, 1, it1, 'psi', tpf, psif(1,1))
         call read_zt (idf_psi, lpsi,npt, 1, it2, 'psi', tpf, psif(1,2))
      endif

      if (icl_ts .eq. 0) return

      call odb_open(idf_t, fbtem(1:n_tem), 0)
      if (icl_h .eq. 0) call data_on_model_grid(idf_t, lclm, 'temp')

      call odb_rddm(idf_t, 'Z', nzclm)
      call mem_alloc(p_zclm, nzclm, 2, 'MZ for temp climatology')
      call odb_rdgr (idf_t, 'Z', nzclm, zclm)
      mz = nzclm


      if (use_salt) then
         call odb_open(idf_s, fbsal(1:n_sal), 0)
         call odb_rddm(idf_s, 'Z', mz)
         if (mz .ne. nzclm) 
     *        call perror1('Temp & Salt DATA should be on the same Z grid', 1)
      endif

      if (icl_ts .eq. 1) then            !!.....time independent case:
         call read_linz(idf_t,lclm,npt,mpack,nz,mz,1,hclf,tclf,zclm,tp,'temp') 
         if (use_salt)
     *   call read_linz(idf_s,lclm,npt,mpack,nz,mz,1,hclf,sclf,zclm,tp,'salt') 

         if (iv_bot .eq. 4) then
            do i = 1, npt
               tclf(i,nz,1) = TEMP_BOT
               if (use_salt) sclf(i,nz,1) = SALT_BOT
            enddo
         endif

      elseif (icl_ts .eq. 2) then        !!.....time dependent case:

         call odb_rddm(idf_t, 'T', i)

         if  (icl_h .ne. 2) then         !!.....H_clim is time independent
            ntclm = i
            call mem_alloc(p_tclm, ntclm, 2, 'tclm')
            call odb_rdgr(idf_t, 'T', ntclm, tclm)
            call it_catch (ntclm, tclm, nstart, it1, it2, clm_tscl)
            iclm = it2
         elseif (i .ne. ntclm ) then
            call perror1('MxTh & Temp DATA should be on the same T grid', 1)
         endif

         if (use_salt) then
            call odb_rddm(idf_s, 'T', i)
            if (i .ne. ntclm) 
     *        call perror1('Temp & Salt DATA should be on the same T grid', 1)
         endif

         call read_linz(idf_t, lclm, npt,mpack,nz,mz, it1,
     *                  hclf(1,1,1),tclf(1,1,1),zclm,tp, 'temp') 
         k2_h = 1
         if (icl_h .eq. 2) k2_h = 2
         call read_linz(idf_t, lclm, npt,mpack,nz,mz, it2,
     *                  hclf(1,1,k2_h),tclf(1,1,2),zclm,tp, 'temp') 

         if (use_salt) then
            call read_linz(idf_s, lclm, npt,mpack,nz,mz, it1,
     *                     hclf(1,1,1),sclf(1,1,1),zclm,tp, 'salt') 
            call read_linz(idf_s, lclm, npt,mpack,nz,mz, it2,
     *                     hclf(1,1,k2_h),sclf(1,1,2),zclm,tp, 'salt') 
         endif

      endif

      if (ipre.eq.1) then
         if (use_salt) call potn_dens (npt,nzi,tclf(1,1,1),sclf(1,1,1),dclf) 
         call dconv_cl (npt,nz,nzi,hclf,tclf(1,1,1),sclf(1,1,1),dclf)
         if (use_salt) call potn_dens (npt,nzi,tclf(1,1,2),sclf(1,1,2),dclf) 
         call dconv_cl (npt,nz,nzi,hclf,tclf(1,1,2),sclf(1,1,2),dclf)
      endif

      if (icl_rlx .eq. 1) then
         do j = 1, nyp
            if     (ym(j) .gt. clm_no) then
               tp(j) = clm_coef * (ym(j)-clm_no)/(ym(nyp)-clm_no)
            elseif (ym(j) .lt. clm_so) then
               tp(j) = clm_coef * (clm_so-ym(j))/(clm_so-ym(1))
            else
               tp(j) = 0.
            endif
         enddo
         
         do i = 1, npt
            j = (iox(i)-1)/nxp + 1
            sponge(i) = tp(j)
         enddo

      elseif (icl_rlx .eq. 2) then
         do i = 1, npt
            sponge(i) = clm_coef
         enddo
      elseif (icl_rlx .eq. 3) then
         dsponge = real(ksponge)
         do i = 1, npt
            ixy = iox(i)
            ix = mod (ixy -1 ,nxp) + 1
            iy = (ixy - ix)/nxp + 1
            dmin = nxp+nyp
            do j = 1, nsponge
               kxy = lsponge(j)
               kx = mod (kxy -1 ,nxp) + 1
               ky = (kxy - kx)/nxp + 1
               d = sqrt(float((ix-kx)**2 + (iy-ky)**2))
c               d = abs(ix-kx) + abs(iy-ky)
               dmin = min(d,dmin)
            enddo
            sponge(i) = clm_coef*max((dsponge-dmin)/dsponge,0.)
         enddo
      endif

      
      return
      end

c     ----------------------------------------------
      subroutine h_init (npt, nz, nzi, nstart, hmf, hclf)
c     ----------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension hmf(npt,1), hclf(npt,nz,1), nzi(1)

      if     (icl_h .eq. 1) then
         do i = 1, npt
            do k = 1, nzi(i)
               hmf(i,k) = hclf(i,k,1) 
            enddo
         enddo

      elseif (icl_h .eq. 2) then
         do i = 1, npt
            do k = 1, nzi(i)
               hmf(i,k) = hclf(i,k,1) +  clm_tscl*(hclf(i,k,2) - hclf(i,k,1))
            enddo
         enddo

      endif
      
      return
      end

c    -----------------------------------------------------------------
      subroutine temp_init (npt, nz, nzi, nstart, t0, tmf, tclf)
c    -----------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension t0(1), tmf(npt,1), tclf(npt,nz,1), nzi(1)
c
      if     (initt .eq. 0) then
c.......constant values for each layer according to T_INIT
         iseed = 10001
         do i = 1, npt
            do k = 1, nzi(i)
               rand = 1.+temp_coef*(2.*ran(iseed)-1.)
               tmf(i,k) = t0(k)*rand
            enddo
         enddo

      elseif (initt .eq. 3) then
c.....from CLIMATOLOGY Data.
         if     (icl_ts .eq. 2) then
            do i = 1, npt
               do k = 1, nzi(i)
                  tmf(i,k) = tclf(i,k,1)+ clm_tscl*(tclf(i,k,2)- tclf(i,k,1))
               enddo
            enddo
         else
            do i = 1, npt
               do k = 1, nzi(i)
                  tmf(i,k) = tclf(i,k,1)
               enddo
            enddo
         endif

      endif

      return
      end

c    -----------------------------------------------------------------
      subroutine salt_init (npt, nz, nzi, nstart, s0, smf, sclf)
c    -----------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension s0(1), smf(npt,1), sclf(npt,nz,1), nzi(1)
c
      if     (inits .eq. 0) then
         do i = 1, npt
            do k = 1, nzi(i)
               smf(i,k) = s0(k)
            enddo
         enddo

      elseif (inits .eq. 3) then
c.....from CLIMATOLOGY Data.
         if     (icl_ts .eq. 2) then
            do i = 1, npt
               do k = 1, nzi(i)
                  smf(i,k) = sclf(i,k,1)+ clm_tscl*(sclf(i,k,2)- sclf(i,k,1))
               enddo
            enddo
         else
            do i = 1, npt
               do k = 1, nzi(i)
                  smf(i,k) = sclf(i,k,1)
               enddo
            enddo
         endif
         
      endif
      
      return
      end

c----------------------------------------------------
      subroutine tau_init (nstart,npt, dtaux, dtauy)
c----------------------------------------------------
c..........initalize the winds according to MTAU
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_data.h'

      parameter (TAUCON = 10300., API = 3.14159265, TAUINV = 1./TAUCON)

      common/winds/mtau,matau,tausc,atau,froude
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch

      dimension dtaux(npt,1),dtauy(npt,1)

      taub = tausc/TAUCON
      tauc = atau/TAUCON

      if     (mtau .eq. 1 .or. mtau .eq. 2) then
         call odb_open(idf_tx, fbwnd(1:n_wnd)//'.x', 0)
         call odb_open(idf_ty, fbwnd(1:n_wnd)//'.y', 0)

         call odb_rddm(idf_tx, 'T', ntau)
         call mem_alloc(p_ttau, ntau, 2, 'ttau')
         call odb_rdgr(idf_tx, 'T', ntau, ttau)

         call it_catch (ntau, ttau, nstart, it1, it2, tscl)
         itau = it2

         call data_on_model_grid(idf_tx, ltau, 'tau')

         call read_zt (idf_tx, ltau, npt, 1, it1, 'taux', tp, dtaux(1,1)) 
         call read_zt (idf_tx, ltau, npt, 1, it2, 'taux', tp, dtaux(1,2)) 
         call read_zt (idf_ty, ltau, npt, 1, it1, 'tauy', tp, dtauy(1,1)) 
         call read_zt (idf_ty, ltau, npt, 1, it2, 'tauy', tp, dtauy(1,2)) 

         do i = 1, npt
            dtaux(i,1) = TAUINV * dtaux(i,1)
            dtaux(i,2) = TAUINV * dtaux(i,2)
            dtauy(i,1) = TAUINV * dtauy(i,1)
            dtauy(i,2) = TAUINV * dtauy(i,2)
         enddo

         if (mtau .eq. 1) then
            do i = 1, npt
               taux(i) = dtaux(i,1) + tscl * (dtaux(i,2) - dtaux(i,1))
               tauy(i) = dtauy(i,1) + tscl * (dtauy(i,2) - dtauy(i,1))
            enddo
         endif

      elseif (mtau .eq. 3) then
c..........3 - annualy averaged climatology
         call odb_open(idf_tx, fbwnd(1:n_wnd)//'.x', 0)
         call odb_open(idf_ty, fbwnd(1:n_wnd)//'.y', 0)

         call odb_rddm(idf_tx, 'T', ntau)

         call data_on_model_grid(idf_tx, ltau, 'tau')

         do k = 1, ntau
            call read_zt (idf_tx, ltau, npt, 1, k, 'taux', tp, dtaux(1,2)) 
            call read_zt (idf_ty, ltau, npt, 1, k, 'tauy', tp, dtauy(1,2)) 

            do i = 1, npt
               dtaux(i,1) = dtaux(i,1) + dtaux(i,2)
               dtauy(i,1) = dtauy(i,1) + dtauy(i,2)
            enddo
         enddo

         coef = TAUINV/real(ntau)
         do i = 1, npt
            taux(i) = coef * dtaux(i,1)
            tauy(i) = coef * dtauy(i,1)
         enddo

      elseif (mtau .eq. 5) then
c..........5 - COSINE winds
         if     (itau_cos .eq. 0) then
            do j = 1, nyp
               tp(j) = taub*cos(API*(ym(j))/80.)
            enddo
         elseif (itau_cos .eq. 1) then
            y1 = ym(1)
            y2 = ym(nyp)
            do j = 1, nyp
               tp(j) = taub*cos(2.*API*( (ym(j)-y1)/(y2-y1) - 0.5))
            enddo
         elseif (itau_cos .eq. 2) then
            y1 = ym(1)
            y2 = ym(nyp)
            do j = 1, nyp
               tp(j) = taub*cos(API*( (ym(j)-y1)/(y2-y1) - 0.5))
            enddo
         endif

         do k = 1, npt
            j = (iox(k)-1)/nxp + 1
            tmpx       = tp(j)
            taux(k)    = tmpx
            dtaux(k,1) = tmpx
            tauy(k)    = tauc
            dtauy(k,1) = tauc
         enddo
      endif

      return
      end

c     ------------------------------------------------------------------
      subroutine tau_lin (nstep,npt,ixd,im2d,blcf, taux,tauy,dtx,dty,tp)
c     ------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'

      parameter (TAUCON = 10300., API = 3.14159265, TAUINV = 1./TAUCON)

      dimension taux(1),tauy(1),dtx(npt,1),dty(npt,1)
      dimension ixd(1),im2d(1),blcf(1),tp(1)

      call it_catch (ntau, ttau, nstep, it1, it2, tscl)

      if (it2 .ne. itau) then
         itau = it2

         do i = 1, npt
            dtx(i,1) = dtx(i,2)
            dty(i,1) = dty(i,2)
         enddo

         call read_zt (idf_tx, ltau, npt, 1, it2, 'taux', tp, dtx(1,2)) 
         call read_zt (idf_ty, ltau, npt, 1, it2, 'tauy', tp, dty(1,2)) 

         do i = 1, npt
            dtx(i,2) = TAUINV * dtx(i,2)
            dty(i,2) = TAUINV * dty(i,2)
         enddo
      endif
      
      do i = 1, npt
         taux(i) = dtx(i,1) + tscl * (dtx(i,2) - dtx(i,1))
         tauy(i) = dty(i,1) + tscl * (dty(i,2) - dty(i,1))
      enddo
      
      return
      end

c     ------------------------------------------------------------------
      subroutine hflx_init (nstart, npt, nx, ny, temp, sstf, cldf, slrf,
     *                      nrelax, lrelax)
c     ------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_pbl.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch

      dimension temp(1), sstf(npt,1), cldf(npt,1), slrf(npt,1), lrelax(1)

      if (initq .eq. 0) then
c.....Haney case  Q = QCOF * (TATM - T) with Heat Transfer Coef.=30 w/m**2/k.  
         do i = 1, npt
            sstf(i,1) = TATM
            sstf(i,3) = TATM
         enddo
         return

      elseif (initq .eq. 1) then
c.....T_atm = initial T(i,1) = const(time)
         do i = 1, npt
            sstf(i,1) = temp(i)
            sstf(i,3) = temp(i)
         enddo

      elseif (initq .eq. 2) then
c.....T_atm = average(SST) = const(time)
         call odb_open(idf_sst, fbsst(1:n_sst), 0)
         call odb_rddm(idf_sst, 'T', nsst)

         call data_on_model_grid(idf_sst, lsst, 'sst') 

         do k = 1, nsst
            call read_zt (idf_sst, lsst, npt, 1, k, 'sst', tp, sstf(1,2)) 

            do i = 1, npt
               sstf(i,1) = sstf(i,1) + sstf(i,2)
            enddo
         enddo

         coef = 1./real(nsst)
         do i = 1, npt
            sstf(i,1) = coef * sstf(i,1)
            sstf(i,3) = sstf(i,1)
         enddo

      elseif (initq .eq. 3) then
c.....T_atm = SST(time) - climatology
         call odb_open(idf_sst, fbsst(1:n_sst), 0)
         call odb_rddm(idf_sst, 'T', nsst)
         call mem_alloc(p_tsst, nsst, 2, 'tsst')
         call odb_rdgr(idf_sst, 'T', nsst, tsst)

         call it_catch (nsst, tsst, nstart, it1, it2, tscl)
         isst = it2

         call data_on_model_grid(idf_sst, lsst, 'sst') 

         call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) 
         call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 

         if (use_wnsp) then
            call odb_open(idf_wsp, fwsp(1:n_wsp), 0)
            call odb_rddm(idf_wsp, 'T', nwsp)

            call read_zt (idf_wsp, lsst, npt, 1, it1, 'wndspd', tp, wnsp(1,1)) 
            call read_zt (idf_wsp, lsst, npt, 1, it2, 'wndspd', tp, wnsp(1,2)) 
         endif


      elseif (initq .eq. 4) then
c.....read Q directly into slrf:
         call odb_open(idf_q, fbq(1:n_q), 0)

         call odb_rddm(idf_q, 'T', nq)
         call mem_alloc(p_tq, nq, 2, 'heatflux')
         call odb_rdgr(idf_q, 'T', nq, tq)

         call it_catch (nq, tq, nstart, it1, it2, tscl)
         iq = it2

         call data_on_model_grid(idf_q, lq, 'heatflux') 

         call read_zt (idf_q, lq, npt, 1, it1, 'heatflux', tp, slrf(1,1)) 
         call read_zt (idf_q, lq, npt, 1, it2, 'heatflux', tp, slrf(1,2)) 

      elseif (initq .eq. 5) then
c.....*second* Richard-Benno formulation: Q = Q(T, solr, wndsp, clouds)
         call odb_open(idf_sst, fbsst(1:n_sst), 0)
         call odb_open(idf_cld, fbcld(1:n_cld), 0)
         call odb_open(idf_slr, fbslr(1:n_slr), 0)

         call odb_rddm(idf_sst, 'T', nsst)
         call mem_alloc(p_tsst, nsst, 2, 'tsst')
         call odb_rdgr(idf_sst, 'T', nsst, tsst)
         call odb_rddm(idf_cld, 'T', i)
         if (i .ne. nsst) 
     *        call perror1('H.flx & cloud data should be on the same grid',1)
         call odb_rddm(idf_slr, 'T', i)
         if (i .ne. nsst) 
     *        call perror1('H.flx & Sol.Rad. data should be on the same grid',1)

         call it_catch (nsst, tsst, nstart, it1, it2, tscl)
         isst = it2

         call data_on_model_grid(idf_sst, lsst, 'sst')

         call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) 
         call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 
         call read_zt (idf_cld, lsst, npt, 1, it1, 'cld', tp, cldf(1,1)) 
         call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) 
         call read_zt (idf_slr, lsst, npt, 1, it1, 'solr',tp, slrf(1,1)) 
         call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) 

      elseif (initq .eq. 6) then
         trans_coef = 0.

      elseif (initq .eq. 7) then
c.....SST = Annual Mean SST; Cld = Annual Mean Cloud Cover:
         call odb_open(idf_sst, fbsst(1:n_sst), 0)
         call odb_open(idf_cld, fbcld(1:n_cld), 0)
         call odb_rddm(idf_cld, 'T', nsst)
         call odb_rddm(idf_cld, 'T', ncld)
         if (nsst .ne. ncld) 
     *      call perror1('SST & Cloud Cover DATA should have same grids', 1)

         call data_on_model_grid(idf_sst, lsst, 'sst')

         do k = 1, nsst
            call read_zt (idf_sst, lsst, npt, 1, k, 'sst', tp, sstf(1,2))
            call read_zt (idf_cld, lsst, npt, 1, k, 'cld', tp, cldf(1,2)) 
 
            do i = 1, npt
               sstf(i,1) = sstf(i,1) + sstf(i,2)
               cldf(i,1) = cldf(i,1) + cldf(i,2)
            enddo
         enddo

         coef = 1./real(nsst)
         do i = 1, npt
            sstf(i,1) = coef * sstf(i,1)
            cldf(i,1) = coef * cldf(i,1)
         enddo

      elseif (initq .eq. 8) then
c.....PBL model Q = Q(T, solr, wndsp, clouds)
         call odb_open(idf_sst, fbsst(1:n_sst), 0)
         call odb_open(idf_cld, fbcld(1:n_cld), 0)
         call odb_open(idf_slr, fbslr(1:n_slr), 0)

         call odb_open(idf_wsp, fwsp(1:n_wsp), 0)
         call odb_open(idf_uwd, fuwd(1:n_uwd), 0)
         call odb_open(idf_vwd, fvwd(1:n_vwd), 0)
         call odb_open(idf_ah,  fah(1:n_ah),   0)
         call odb_open(idf_at,  fat(1:n_at),   0)

         call odb_rddm(idf_sst, 'T', nsst)
         call odb_rddm(idf_cld, 'T', ncld)
         call odb_rddm(idf_slr, 'T', nslr)
         call odb_rddm(idf_wsp, 'T', nwsp)
         call odb_rddm(idf_uwd, 'T', nuwd)
         call odb_rddm(idf_vwd, 'T', nvwd)
         call odb_rddm(idf_ah, 'T', nah)
         call odb_rddm(idf_at, 'T', nat)

         if (initq.eq.8 .and. nslr.ne.nsst) 
     *        call perror1('Solar radiation data is not on PBL grid', 1)
         if (nsst+ncld+nwsp+nuwd+nvwd+nah+nat .ne. 7*nsst)
     *        call perror1('All PBL data should be on the same grid', 1)

         call mem_alloc(p_tsst, nsst, 2, 'tsst')
         call odb_rdgr(idf_sst, 'T', nsst, tsst)

         call it_catch (nsst, tsst, nstart, it1, it2, tscl)
         isst = it2

         call data_on_model_grid(idf_sst, lsst, 'sst')

         call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) 
         call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 

         call read_zt (idf_cld, lsst, npt, 1, it1, 'cld', tp, cldf(1,1)) 
         call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) 

         call read_zt (idf_slr, lsst, npt, 1, it1, 'solr',tp, slrf(1,1)) 
         call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) 

         call read_zt (idf_wsp, lsst, npt, 1, it1, 'wndspd', tp, wnsp(1,1)) 
         call read_zt (idf_wsp, lsst, npt, 1, it2, 'wndspd', tp, wnsp(1,2)) 

         call read_zt (idf_uwd, lsst, npt, 1, it1, 'uwnd', tp, uwnd(1,1)) 
         call read_zt (idf_uwd, lsst, npt, 1, it2, 'uwnd', tp, uwnd(1,2)) 

         call read_zt (idf_vwd, lsst, npt, 1, it1, 'vwnd', tp, vwnd(1,1)) 
         call read_zt (idf_vwd, lsst, npt, 1, it2, 'vwnd', tp, vwnd(1,2)) 

         NXY = nxp * nyp
#ifdef gidon
         call read_zt (idf_ah,  0,    NXY, 1, it1, 'spechum', tp, ahum(1,1)) 
         call read_zt (idf_ah,  0,    NXY, 1, it2, 'spechum', tp, ahum(1,2)) 
         call read_zt (idf_at,  0,    NXY, 1, it1, 'Tair', tp, atem(1,1)) 
         call read_zt (idf_at,  0,    NXY, 1, it2, 'Tair', tp, atem(1,2)) 
#else 
         call read_zt (idf_ah,  0,    NXY, 1, it1, 'airhum', tp, ahum(1,1)) 
         call read_zt (idf_ah,  0,    NXY, 1, it2, 'airhum', tp, ahum(1,2)) 
         call read_zt (idf_at,  0,    NXY, 1, it1, 'airtem', tp, atem(1,1)) 
         call read_zt (idf_at,  0,    NXY, 1, it2, 'airtem', tp, atem(1,2)) 
#endif
         drelax = real(krelax)
         do i = 1, npt
            ixy = iox(i)
            ix = mod (ixy -1 ,nxp) + 1
            iy = (ixy - ix)/nxp + 1
            dmin = nxp+nyp
            do j = 1, nrelax
               kxy = lrelax(j)
               kx = mod (kxy -1 ,nxp) + 1
               ky = (kxy - kx)/nxp + 1
               d = sqrt(float((ix-kx)**2 + (iy-ky)**2))
               dmin = min(d,dmin)
            enddo
            relax(i) = max((drelax-dmin)/drelax,0.)
         enddo

      endif
      return
      end

c     ---------------------------------------------------
      subroutine ep_init (nstart, npt, salt, sssf, prpf)
c     ---------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_data.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch

      dimension salt(1), sssf(npt,1), prpf(npt,1)
      
      if (initep .eq. 0) then
c   given by EP = QCOF * (SATM - S) with Salt Transfer Coef.=30 o.e./m**2. 
         do i = 1, npt
            sssf(i,1) = SATM
            sssf(i,3) = SATM
         enddo
         return
         
      elseif (initep .eq. 1) then
c.....S_atm = initial S(i,1) = const(time)
         do i = 1, npt
            sssf(i,1) = salt(i)
            sssf(i,3) = salt(i)
         enddo

      elseif (initep .eq. 2) then
c.....S_atm = average(SSS) = const(time)
         call odb_open(idf_sss, fbsss(1:n_sss), 0)
         call odb_rddm(idf_sss, 'T', nsss)
         if (nsst .ne. nsss) 
     *      call perror1('SST & SSS DATA should be on the same T grid',1)

         do k = 1, nsst
            call read_zt (idf_sss, lsst, npt, 1, k, 'sss', tp, sssf(1,2)) 

            do i = 1, npt
               sssf(i,1) = sssf(i,1) + sssf(i,2)
            enddo
         enddo

         coef = 1./real(nsst)
         do i = 1, npt
            sssf(i,1) = coef * sssf(i,1)
            sssf(i,3) = sssf(i,1)
         enddo

      elseif (initep .eq. 3) then
c.....S_atm = SSS(time) - climatology
         call odb_open(idf_sss, fbsss(1:n_sss), 0)
         call odb_rddm(idf_sss, 'T', nsss)
         if (nsst .ne. nsss) 
     *      call perror1('SST & SSS DATA should be on the same T grid',1)

         call it_catch (nsst, tsst, nstart, it1, it2, tscl)
         isss = it2
         call read_zt (idf_sss, lsst, npt, 1, it1, 'sss', tp, sssf(1,1)) 
         call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) 

      elseif (initep .eq. 4) then
c.....read EP directly:
         call odb_open(idf_prp, fbprp(1:n_prp), 0)

         call odb_rddm(idf_prp, 'T', nprp)
         call mem_alloc(p_tprp, nprp, 2, 'precip')
         call odb_rdgr(idf_prp, 'T', nprp, tprp)

         call it_catch (nprp, tprp, nstart, it1, it2, tscl)
         iprp = it2

         call data_on_model_grid(idf_prp, lprp, 'precip') 

         call read_zt (idf_prp, lprp, npt, 1, it1, 'precip', tp, prpf(1,1)) 
         call read_zt (idf_prp, lprp, npt, 1, it2, 'precip', tp, prpf(1,2)) 

      elseif (initep .eq. 6) then
         trans_coef = 0.

      elseif (initep.eq.8) then

         call odb_open(idf_sss, fbsss(1:n_sss), 0)
         call odb_open(idf_prp, fbprp(1:n_prp), 0)

         call odb_rddm(idf_sss, 'T', nsss)
         call odb_rddm(idf_prp, 'T', nprp)

         if(nprp.ne.nsst) call perror1('prp should have PBL T grid',1)
         if (nsss .ne. nsst) 
     *      call perror1('SST & SSS DATA should be on the same T grid',1)

         call it_catch (nsst, tsst, nstart, it1, it2, tscl)

         isss = it2
         call read_zt (idf_sss, lsst, npt, 1, it1, 'sss', tp, sssf(1,1)) 
         call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) 

         iprp = it2
         call read_zt (idf_prp, lsst,npt,1,it1,'precip' ,tp, prpf(1,1)) 
         call read_zt (idf_prp, lsst,npt,1,it2,'precip' ,tp, prpf(1,2)) 
      endif

      return
      end

c--------------------------------------------------------------------
      subroutine qforc(nstep, npt, nx, ny, sstf, cldf, slrf, tpf, qbf) 
c---------------------------------------------------------------------
c     update heat flux using current t(1), and SST(i)
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_pbl.h'
      dimension slrf(npt,1),sstf(npt,1),cldf(npt,1), tpf(npt,1), qbf(npt,1)

      if     (initq .eq. 0) then
         do i = 1, npt
            q(i) = trans_coef * (TATM - t(i))
         enddo

      elseif (initq .eq. 1 .or. initq .eq. 2) then
         do i = 1, npt
            q(i) = trans_coef * (sstf(i,1) - t(i))
         enddo

      elseif (initq .eq. 3) then

         call it_catch (nsst, tsst, nstep, it1, it2, sst_tscl)

         if (it2 .ne. isst) then
            isst = it2
            do i = 1, npt
               sstf(i,1) = sstf(i,2)
            enddo
            
            call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 

            if (use_wnsp) then
               do i = 1, npt
                  wnsp(i,1) = wnsp(i,2)
               enddo
               call read_zt (idf_wsp,lsst,npt, 1, it2, 'wndspd', tp, wnsp(1,2)) 
            endif
         endif

         do i = 1, npt
            sst_d = sstf(i,1) + sst_tscl * (sstf(i,2) - sstf(i,1))
            q(i) = trans_coef * (sst_d - t(i)) 
            sstf(i,3) = sst_d
         enddo
         if (use_wnsp) then
            do i = 1, npt
               tpf(i,1)  = wnsp(i,1) + sst_tscl * (wnsp(i,2) - wnsp(i,1))
            enddo
         endif

      elseif (initq .eq. 4) then
c.....input heat flux directly from file

         call it_catch (nq, tq, nstep, it1, it2, tscl)

         if (it2 .ne. iq) then
            iq = it2
            do i = 1, npt
               slrf(i,1) = slrf(i,2)
            enddo

            call read_zt (idf_q, lq, npt, 1, it2, 'heatflux', tp, slrf(1,2)) 
         endif

         do i = 1, npt
            slrf(i,3) = slrf(i,1) + tscl * (slrf(i,2) - slrf(i,1))
         enddo
         
         qcon_inv = 1./QCON
         do i = 1, npt
c...........assumes that slr data in [watts/m^2]:
            q(i) = qcon_inv * slrf(i,3)
         enddo

      elseif (initq .eq. 5) then
c.....*new* Richard-Benno formulation using Solar Radiation & Clouds:
         call it_catch (nsst, tsst, nstep, it1, it2, tscl)
         if (it2 .ne. isst) then
            isst = it2
            do i = 1, npt
               sstf(i,1) = sstf(i,2)
               cldf(i,1) = cldf(i,2)
               slrf(i,1) = slrf(i,2)
            enddo

            call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 
            call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) 
            call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) 
         endif
         
         do i = 1, npt
            sstf(i,3) = sstf(i,1) + tscl * (sstf(i,2) - sstf(i,1))
            cldf(i,3) = cldf(i,1) + tscl * (cldf(i,2) - cldf(i,1))
            slrf(i,3) = slrf(i,1) + tscl * (slrf(i,2) - slrf(i,1))
         enddo
         call hflx_s94(npt,t,taux,tauy,sstf(1,3),cldf(1,3),slrf(1,3),q,qr,qb)

      elseif (initq .eq. 7) then

         tenso = enso_start + enso_scale * nstep
         call hflx_s89(tenso,npt,iox,t,sstf,cldf,ym,taux,tauy,q,qr,qb,tpf)

      elseif (initq .eq. 8) then
c.....PBL model

         call it_catch (nsst, tsst, nstep, it1, it2, tscl)

         NXY = nx*ny

         newread = 0
         if (it2 .ne. isst) then
            newread = 1
            isst = it2

            do i = 1, npt
               sstf(i,1) = sstf(i,2)
               cldf(i,1) = cldf(i,2)
               slrf(i,1) = slrf(i,2)
               wnsp(i,1) = wnsp(i,2)
               uwnd(i,1) = uwnd(i,2)
               vwnd(i,1) = vwnd(i,2)
            enddo

            do i = 1, NXY
               ahum(i,1) = ahum(i,2)
               atem(i,1) = atem(i,2)
            enddo

            call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 
            call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) 
            call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) 

            call read_zt (idf_wsp, lsst, npt, 1, it2, 'wndspd', tp, wnsp(1,2)) 
            call read_zt (idf_uwd, lsst, npt, 1, it2, 'uwnd', tp, uwnd(1,2)) 
            call read_zt (idf_vwd, lsst, npt, 1, it2, 'vwnd', tp, vwnd(1,2)) 

#ifdef gidon
         call read_zt (idf_ah,  0,    NXY, 1, it2, 'spechum', tp, ahum(1,2)) 
         call read_zt (idf_at,  0,    NXY, 1, it2, 'Tair', tp, atem(1,2)) 
#else 
         call read_zt (idf_ah,  0,    NXY, 1, it2, 'airhum', tp, ahum(1,2)) 
         call read_zt (idf_at,  0,    NXY, 1, it2, 'airtem', tp, atem(1,2)) 
#endif
         endif

         if (newread.eq.1 .or.FIRST_STEP .or.mod(nstep, nstep_pbl).eq.0) then 
            do i = 1, npt
               sstf(i,3) = sstf(i,1) + tscl * (sstf(i,2) - sstf(i,1))
               cldf(i,3) = cldf(i,1) + tscl * (cldf(i,2) - cldf(i,1))
               tpf(i,2)  = uwnd(i,1) + tscl * (uwnd(i,2) - uwnd(i,1))
               tpf(i,3)  = vwnd(i,1) + tscl * (vwnd(i,2) - vwnd(i,1))
            enddo
            
            do i = 1, npt
               wnd_speed = wnsp(i,1) + tscl * (wnsp(i,2) - wnsp(i,1))
               if (wnd_speed .lt. pbl_wmin) then
                  tpf(i,1) = pbl_wmin
               else
                  tpf(i,1) = wnd_speed
               endif
            enddo

            do i = 1, NXY
               ahum(i,3) = ahum(i,1) + tscl * (ahum(i,2) - ahum(i,1))
               atem(i,3) = atem(i,1) + tscl * (atem(i,2) - atem(i,1))
            enddo

            call htflux_pbl (npt, nx, ny, iox, xm, ym, 
     *         t,cldf(1,3), tpf(1,1),tpf(1,2),tpf(1,3), ahum(1,3),atem(1,3), 
     *         qbf(1,2), qbf(1,3), qbf(1,4), amhum, amth)
         endif

         qcon_inv = 1./QCON
         qcon_gam = solr_gamma/QCON
         do i = 1, npt
            qsolr    = slrf(i,1) + tscl * (slrf(i,2) - slrf(i,1))
            qbf(i,1) = qsolr
            qcorr = trans_coef * (sstf(i,3) - t(i))
            qbf(i,5) = QCON * qcorr

c...........Total Heat Flux at the surface:
c...........Q = (1-gamma)*Q_sol - Q_lh - Q_sh - Q_lw
            qr(i) = qcon_gam * qsolr
            qtot  = qsolr - qbf(i,2) - qbf(i,3) - qbf(i,4)
            rx = relax(i)
            q(i)  = qcon_inv * qtot - qr(i) + rx * qcorr
         enddo


      endif
      
      return
      end

c---------------------------------------------------------
      subroutine epforc(nstep, npt, salt, sssf, prpf, qbf)
c---------------------------------------------------------
c     update EP using current sal(1), and SSS(i)
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_data.h'
      include 'comm_new.h'
      dimension salt(1),sssf(npt,1), qbf(npt,1), prpf(npt,1)
      parameter (R_MMDAY2MSEC = 1./(24. * 3600. * 1000.))
      parameter (CLATHT2EVAP = 1./(2.5e6*1028.))

      if     (initep .eq. 0) then
         do i = 1, npt
            ep(i) = trans_coef * (SATM - salt(i))
         enddo

      elseif (initep .eq. 1 .or. initep .eq. 2) then
         do i = 1, npt
            ep(i) = trans_coef * (sssf(i,1) - salt(i))
         enddo

      elseif (initep .eq. 3) then

         if (isss .ne. isst) then
            isss = isst
            do i = 1, npt
               sssf(i,1) = sssf(i,2)
            enddo

            call read_zt (idf_sss, lsst, npt, 1, isss, 'sss', tp, sssf(1,2)) 
         endif

         do i = 1, npt
            sss_d = sssf(i,1) + sst_tscl * (sssf(i,2) - sssf(i,1))
            ep(i) = trans_coef * (sss_d - salt(i)) 
            sssf(i,3) = sss_d
         enddo

      elseif (initep .eq. 4) then
         call it_catch (nprp, tprp, nstep, it1, it2, tscl)

         if (it2 .ne. iprp) then
            iprp = it2
            do i = 1, npt
               prpf(i,1) = prpf(i,2)
            enddo

            call read_zt (idf_prp, lprp, npt, 1, it2, 'precip', tp, prpf(1,2)) 
         endif
         
         do i = 1, npt
c...........assumes that prp data in [mm/day]:
            E_P = prpf(i,1) + tscl * (prpf(i,2) - prpf(i,1))
            ep(i) = R_MMDAY2MSEC * salt(i) * E_P 
         enddo

      elseif (initep.eq.8) then
         call it_catch (nsst, tsst, nstep, it1, it2, tscl)

         if (it2 .ne. iprp) then
            iprp = it2
            do i = 1, npt
               prpf(i,1) = prpf(i,2)
               sssf(i,1) = sssf(i,2)
            enddo

            call read_zt (idf_prp, lsst, npt, 1, it2, 'precip',tp,prpf(1,2)) 
            call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) 

         endif
         
         do i = 1, npt
            precip = R_MMDAY2MSEC *(prpf(i,1) + tscl*(prpf(i,2) - prpf(i,1)))
#ifdef gidon
            evapor = CLATHT2EVAP * qbf(i,2) * 0.7
#else
            evapor = CLATHT2EVAP * qbf(i,2) 
#endif
            sss_d = sssf(i,1) + tscl * (sssf(i,2) - sssf(i,1))
            ecorr = trans_coef * (sss_d - salt(i))
            rx = relax(i)
            ep(i) = (evapor - precip) * salt(i) + rx * ecorr
         enddo
      endif
      
      return
      end

c---------------------------------------------
      subroutine amlice_flux(nstep, delt, npt, nx, ny,
     *                    sstf, cldf, slrf, tpf, salt, sssf, prpf, qbf)
c---------------------------------------------
c.....AML(Richard) + ICE(Martin,Bob)
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_pbl.h'
      include 'amlice.h'
      dimension slrf(npt,1),sstf(npt,1),cldf(npt,1), tpf(npt,1), qbf(npt,1)
      dimension salt(1),sssf(npt,1),prpf(npt,1)
      parameter (R_MMDAY2MSEC = 1./(24. * 3600. * 1000.))
      parameter (CLATHT2EVAP = 1./(2.5e6*1028.))
      parameter (D2SEC = 24. * 3600.)

      call it_catch (nsst, tsst, nstep, it1, it2, tscl)
      
      NXY = nx*ny

      dtpbl   = delt * real(nstep_pbl) * D2SEC
      
      newread = 0
      if (it2 .ne. isst) then
         newread = 1
         isst = it2
         
         do i = 1, npt
            sstf(i,1) = sstf(i,2)
            cldf(i,1) = cldf(i,2)
            slrf(i,1) = slrf(i,2)
            wnsp(i,1) = wnsp(i,2)
            uwnd(i,1) = uwnd(i,2)
            vwnd(i,1) = vwnd(i,2)
            prpf(i,1) = prpf(i,2)
         enddo
         
         do i = 1, NXY
            ahum(i,1) = ahum(i,2)
            atem(i,1) = atem(i,2)
         enddo
         
         nxy = nx*ny
         call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 
         call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) 
         call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) 
         
         call read_zt (idf_wsp, lsst, npt, 1, it2, 'wndspd', tp, wnsp(1,2)) 
         call read_zt (idf_uwd, lsst, npt, 1, it2, 'uwnd', tp, uwnd(1,2)) 
         call read_zt (idf_vwd, lsst, npt, 1, it2, 'vwnd', tp, vwnd(1,2)) 
         
         call read_zt (idf_ah,  0, nxy, 1, it2, 'airhum', tp, ahum(1,2)) 
         call read_zt (idf_at,  0, nxy, 1, it2, 'airtem', tp, atem(1,2)) 

         call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) 

         if (initep.eq.8) then
            call read_zt (idf_prp, lsst, npt, 1, it2, 'precip', tp, prpf(1,2)) 
         endif
      endif

      if (newread.eq.1 .or.FIRST_STEP .or.mod(nstep, nstep_pbl).eq.0) then 
         do i = 1, npt
            sstf(i,3) = sstf(i,1) + tscl * (sstf(i,2) - sstf(i,1))
            cldf(i,3) = cldf(i,1) + tscl * (cldf(i,2) - cldf(i,1))
            slrf(i,3) = slrf(i,1) + tscl * (slrf(i,2) - slrf(i,1))
            tpf(i,2)  = uwnd(i,1) + tscl * (uwnd(i,2) - uwnd(i,1))
            tpf(i,3)  = vwnd(i,1) + tscl * (vwnd(i,2) - vwnd(i,1))
            sssf(i,3) = sssf(i,1) + tscl * (sssf(i,2) - sssf(i,1))
            prpf(i,3) = prpf(i,1) + tscl * (prpf(i,2) - prpf(i,1))
            prpf(i,3) = R_MMDAY2MSEC * prpf(i,3)
            slrf(i,3) = - slrf(i,3)/(1. - albedoocean)
         enddo
         
         do i = 1, npt
            wnd_speed = wnsp(i,1) + tscl * (wnsp(i,2) - wnsp(i,1))
            if (wnd_speed .lt. pbl_wmin) then
               tpf(i,1) = pbl_wmin
            else
               tpf(i,1) = wnd_speed
            endif
         enddo
         
         do i = 1, NXY
            ahum(i,3) = ahum(i,1) + tscl * (ahum(i,2) - ahum(i,1))
            atem(i,3) = atem(i,1) + tscl * (atem(i,2) - atem(i,1))
         enddo
         
         call link2htfluxice (npt, nx, ny, iox, xm, ym, dtpbl, 
     *        t,cldf(1,3), tpf(1,1),tpf(1,2),tpf(1,3),ahum(1,3),atem(1,3), 
     *        qbf(1,2), qbf(1,3), qbf(1,4), amhum, amth, rh, 
     *        sal, slrf(1,3), prpf(1,3), qbf, pp, qios, brne,
     *        hice, cice, thice, tsnw, rlhi, shi, qlwi, qswi)
      endif
      
      qcon_inv = 1./QCON
      do i = 1, npt
         qcorr = trans_coef * (sstf(i,3) - t(i))
         qbf(i,5) = QCON * qcorr
         
c...........Total Heat Flux at the surface:
c          qbf(*,1:2:3:4) = (*,qsw:rlh:sh:qlw)

         qtot  = - qbf(i,1) - qbf(i,2) - qbf(i,3) - qbf(i,4) - qios(i)
         rx = relax(i)
         q(i)  = qcon_inv * qtot + rx * qcorr
         
         precip = pp(i)
         evapor = CLATHT2EVAP * qbf(i,2) 
         ecorr = trans_coef * (sssf(i,3) - salt(i))
         rx = relax(i)
         ep(i) = (evapor - precip - brne(i)) * salt(i) + rx * ecorr
      enddo
      
      return
      end
            
c---------------------------------------------
      subroutine amlice_data_init(nstart, npt, nx, ny, 
     *                  temp, sstf, cldf, slrf, salt, sssf, prpf, 
     *                    nrelax, lrelax)
c---------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_pbl.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc

      dimension temp(1), sstf(npt,1), cldf(npt,1), slrf(npt,1), lrelax(1)
      dimension salt(1), sssf(npt,1), prpf(npt,1)

      call odb_open(idf_sst, fbsst(1:n_sst), 0)
      call odb_open(idf_cld, fbcld(1:n_cld), 0)
      call odb_open(idf_slr, fbslr(1:n_slr), 0)
      
      call odb_open(idf_wsp, fwsp(1:n_wsp), 0)
      call odb_open(idf_uwd, fuwd(1:n_uwd), 0)
      call odb_open(idf_vwd, fvwd(1:n_vwd), 0)
      call odb_open(idf_ah,  fah(1:n_ah),   0)
      call odb_open(idf_at,  fat(1:n_at),   0)
      
      call odb_open(idf_sss, fbsss(1:n_sss), 0)
      call odb_open(idf_prp, fbprp(1:n_prp), 0)
      
      call odb_rddm(idf_sst, 'T', nsst)
      call odb_rddm(idf_cld, 'T', ncld)
      call odb_rddm(idf_slr, 'T', nslr)
      call odb_rddm(idf_wsp, 'T', nwsp)
      call odb_rddm(idf_uwd, 'T', nuwd)
      call odb_rddm(idf_vwd, 'T', nvwd)
      call odb_rddm(idf_ah, 'T', nah)
      call odb_rddm(idf_at, 'T', nat)
      
      call odb_rddm(idf_sss, 'T', nsss)
      call odb_rddm(idf_prp, 'T', nprp)
      
      if (nslr.ne.nsst) 
     *     call perror1('Solar radiation data is not on PBL grid', 1)
      if(initep.eq.8 .and. nprp.ne.nsst)
     *     call perror1('prp should have PBL T grid',1)
      
      if (nsst+ncld+nwsp+nuwd+nvwd+nah+nat+nsss .ne. 8*nsst)
     *     call perror1('All PBL data should be on the same grid', 1)
      
      call mem_alloc(p_tsst, nsst, 2, 'tsst')
      call odb_rdgr(idf_sst, 'T', nsst, tsst)
      
      call it_catch (nsst, tsst, nstart, it1, it2, tscl)
      isst = it2
      
      call data_on_model_grid(idf_sst, lsst, 'sst')
      
      call read_zt (idf_sst, lsst, npt, 1, it1, 'sst', tp, sstf(1,1)) 
      call read_zt (idf_sst, lsst, npt, 1, it2, 'sst', tp, sstf(1,2)) 
      
      call read_zt (idf_cld, lsst, npt, 1, it1, 'cld', tp, cldf(1,1)) 
      call read_zt (idf_cld, lsst, npt, 1, it2, 'cld', tp, cldf(1,2)) 
      
      call read_zt (idf_slr, lsst, npt, 1, it1, 'solr',tp, slrf(1,1)) 
      call read_zt (idf_slr, lsst, npt, 1, it2, 'solr',tp, slrf(1,2)) 
      
      call read_zt (idf_wsp, lsst, npt, 1, it1, 'wndspd', tp, wnsp(1,1)) 
      call read_zt (idf_wsp, lsst, npt, 1, it2, 'wndspd', tp, wnsp(1,2)) 
      
      call read_zt (idf_uwd, lsst, npt, 1, it1, 'uwnd', tp, uwnd(1,1)) 
      call read_zt (idf_uwd, lsst, npt, 1, it2, 'uwnd', tp, uwnd(1,2)) 
      
      call read_zt (idf_vwd, lsst, npt, 1, it1, 'vwnd', tp, vwnd(1,1)) 
      call read_zt (idf_vwd, lsst, npt, 1, it2, 'vwnd', tp, vwnd(1,2)) 
      
      call read_zt (idf_sss, lsst, npt, 1, it1, 'sss', tp, sssf(1,1)) 
      call read_zt (idf_sss, lsst, npt, 1, it2, 'sss', tp, sssf(1,2)) 
      
      if (initep.eq.8) then
         call read_zt (idf_prp, lsst, npt, 1, it1, 'precip', tp, prpf(1,1)) 
         call read_zt (idf_prp, lsst, npt, 1, it2, 'precip', tp, prpf(1,2)) 
      endif
      
      nxy = nx*ny
      call read_zt (idf_ah,  0, nxy, 1, it1, 'airhum', tp, ahum(1,1)) 
      call read_zt (idf_ah,  0, nxy, 1, it2, 'airhum', tp, ahum(1,2)) 
      call read_zt (idf_at,  0, nxy, 1, it1, 'airtem', tp, atem(1,1)) 
      call read_zt (idf_at,  0, nxy, 1, it2, 'airtem', tp, atem(1,2)) 
      
      drelax = real(krelax)
      do i = 1, npt
         ixy = iox(i)
         ix = mod (ixy -1 ,nxp) + 1
         iy = (ixy - ix)/nxp + 1
         dmin = nxp+nyp
         do j = 1, nrelax
            kxy = lrelax(j)
            kx = mod (kxy -1 ,nxp) + 1
            ky = (kxy - kx)/nxp + 1
            d = sqrt(float((ix-kx)**2 + (iy-ky)**2))
            dmin = min(d,dmin)
         enddo
         relax(i) = max((drelax-dmin)/drelax,0.)
      enddo
      
      return
      end
      
      subroutine hbcset(npt, nzp, nsig, lok, hmf, hclf)
c---------------------------------------------
c     apply B.C. to the H field if relaxing to climatology.

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_para.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension hmf(npt,1),hclf(npt,nzp,1)
      dimension lok(4*MAXSID,nz)

      nlo = nlok(1)

      if     (icl_h .eq. 1) then
         do k = 1, nsig
            do n = 1, nlo
               i = lok(n,1)
               hmf(i,k) = hclf(i,k,1)
            enddo
         enddo

      elseif (icl_h .eq. 2) then
         do k = 1, nsig
            do n = 1, nlo
               i = lok(n,1)
               hmf(i,k) = hclf(i,k,1) + clm_tscl*(hclf(i,k,2) - hclf(i,k,1))
            enddo
         enddo
      endif

      return
      end

c-----------------------------------------------------
      subroutine tbcset(npt, nzp, lok, t0, hmf, tmf, tclf)
c-----------------------------------------------------
c     apply B.C. to the temperature field.  The land boundaries have zero 
c     heat flux, the open ocean boundaries have a specified temperature.
c
c     lok  = (input)  regular or compressed x-sort indices of the "open
c                     ocean" boundary points at which t is constant.
c     nlok = (common) number of open ocean grid points.  nlo .gt. 0 is
c                    equivalent to having mtc=1 in previous versions
c                    of the model.

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_para.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension t0(1),tmf(npt,1),hmf(npt,1),tclf(npt,nzp,1)
      dimension lok(4*MAXSID,nz)
c
      if     (icl_ts .eq. 0) then
         do k = 1, nz
            nlk = nlok(k)
            if (nlk.eq.0) return
            tik = t0(k)
            do n = 1, nlk
               i = lok(n,k)
               tmf(i,k) = tik * hmf(i,k)
            enddo
         enddo

      elseif (icl_ts .eq. 1) then
         do k = 1, nz
            nlk = nlok(k)
            if (nlk.eq.0) return
            do n = 1, nlk
               i = lok(n,k)
               tmf(i,k) = tclf(i,k,1)*hmf(i,k)
            enddo
         enddo

      elseif (icl_ts .eq. 2) then
         do k = 1, nz
            nlk = nlok(k)
            if (nlk.eq.0) return
            do n = 1, nlk
               i = lok(n,k)
               tmf(i,k) = hmf(i,k) * 
     *              (tclf(i,k,1) + clm_tscl*(tclf(i,k,2) - tclf(i,k,1)))
            enddo
         enddo

      endif
            

      return
      end

c----------------------------------------------------------------------
      subroutine it_catch (NN, tt, nstep, it1, it2, tscl)
c----------------------------------------------------------------------
c.....Returns relative shift & indexes which are bracket nstep. 
      implicit real(a-h,o-z),integer(i-n)
      dimension tt(1)
      include 'comm_new.h'

      denso = enso_start + enso_scale * nstep

      tstep = tt(2) - tt(1)

      if (tt(nn)-tt(1)+tstep .eq. 12.) then
c.....Periodic Climatology Data
c#         denso = denso - 12.*(int(denso)/12)
         denso = mod(denso, 12.)
         if (denso .lt. 0.) denso = denso + 12. 

      
         do it2 = 1, NN
            if (denso .lt. tt(it2)) goto 100 
         enddo
         denso = denso - 12.
         it2 = 1
  100    if (it2 .eq. 1) then 
            it1  = NN
            tscl = (12. - tt(NN) + denso)/(12. - tt(NN) + tt(1)) 
         else
            it1  = it2 - 1
            tscl = (denso - tt(it1))/(tt(it2) - tt(it1)) 
         endif
      else
c.....Non-periodic Data       
         do it2 = 1, NN
            if (denso .lt. tt(it2)) goto 200 
         enddo
         it2 = NN+1
         tscl = 0.
  200    if    (it2 .eq. 1) then
            it1  = 1
            tscl = 0.
         elseif(it2 .eq. NN+1) then
            it1  = NN
            it2  = NN
            tscl = 0.
         else
            it1  = it2 - 1
            tscl = (denso - tt(it1))/(tt(it2) - tt(it1)) 
         endif
      endif
      return
      end

c--------------------------------------------------------
      subroutine data_on_model_grid (idf, lret, tag)
c--------------------------------------------------------
      character*(*) tag
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch

      include 'comm_new.h'
      include 'comm_data.h'

      logical grids_equiv

      lret = 1
      if (idatgr .eq. 0) then
c........check if data on the same grid as the model:
         if ( grids_equiv(idf, nxp,nyp,nxyc, nsx,nsy, tp)) lret = 0

c........check if data on the same grid as previous data:
      elseif ( grids_equiv(idf, mxp,myp,mpack,msx,msy, tp)) then 
         lret = 1

c........check if data on the same grid as the model:
      elseif ( grids_equiv(idf, nxp,nyp,nxyc, nsx,nsy, tp)) then
         lret = 0

      else
         write(6, *) tag, 'Only one data GRID allowed! Stop.'
         stop
      endif
      
      return
      end

c-------------------------------------------------------------------
      logical function grids_equiv (idf, kxp,kyp,kpack,ksx,ksy, tpp)
c-------------------------------------------------------------------
      dimension tpp(1), kask(1000)
      logical odb_ifatt

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      include 'comm_new.h'
      include 'comm_data.h'

      m_p = 0
      call odb_rddm(idf, 'NPACK', m_p)
      m_x = 0
      call odb_rdgr(idf, 'X', m_x, tpp)
      xer = 1.e-6*(xm(nxp) - xm(1))  
      if (xm(1) .lt. tpp(1)-xer .or. xm(nxp) .gt. tpp(m_x)+xer) then
         write (6, *) '!!! X grid of DATA must cover the model region'
         stop
      endif

      m_sx = 0
      if ( odb_ifatt(idf, 'X', 'stretched') )
     *     call odb_getiattr(idf, 'X', 'stretched', m_sx) 

      m_y = 0
      yer = 1.e-6*(ym(nyp) - ym(1))  
      call odb_rdgr(idf, 'Y', m_y, tpp(m_x+1))
      if (ym(1).lt. tpp(m_x+1)-yer .or. ym(nyp) .gt. tp(m_x+m_y)+yer) then
         write (6, *) '!!! Y grid of DATA must cover the model region'
         stop
      endif
      m_sy = 0
      if ( odb_ifatt(idf, 'Y', 'stretched') )
     *     call odb_getiattr(idf, 'Y', 'stretched', m_sy) 

      m_seg = 0
      call odb_rddm (idf, 'NMASK', m_seg)
      call odb_rdvar(idf, 'MASK',  tpp(m_x+m_y+1))

      if (m_p.ne.kpack .or. 
     *    m_x.ne.kxp   .or. m_y.ne.kyp .or.
     *    m_sx.ne.ksx  .or. m_sy.ne.ksy ) then

         grids_equiv = .FALSE.
         if (idatgr .eq. 0) then
            mpack = m_p
            mxp   = m_x
            msx   = m_sx
            myp   = m_y
            msy   = m_sy
            mseg  = m_seg

            call datagrid_memory(tp)
            call blin_indx(tp)
            call blin_coef(tp(mseg+1))
         endif
      else
         grids_equiv = .TRUE.
      endif

      return
      end

c-----------------------------------------------------------------
      subroutine read_zt (idf, key, npt, iz, it, tag, ftmp, fdata) 
c-----------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension ftmp(1), fdata(1)
      character*(*) tag
      include 'comm_data.h'
      
      if (key .eq. 0) then      !! data on MODEL grid
         call odb_rd1v3 (idf, iz, it, tag, fdata)
      else                      !! data on a different grid
         call odb_rd1v3 (idf, iz, it, tag, ftmp)
         call blin_intr(npt, ixd, im2d, blcf, ftmp, fdata)
      endif
      return
      end

c-------------------------------------------------------
      integer function nearest(ixy, xd, yd, iseg)
c-------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension xd(1), yd(1), iseg(1)
      include 'comm_new.h'

      iy0 = 1 + (ixy-1)/mxp
      ix0 = ixy - mxp*(iy0-1)
      x0 = xd(ix0)
      y0 = yd(iy0)

      nearest = iseg(1)
      iy = 1       + (nearest-1)/mxp
      ix = nearest - (iy-1)*mxp
      dmin = (xd(ix)-x0)**2 + (yd(iy)-y0)**2
      
      do j = 2, mseg
         i = iseg(j)
         iy = 1 + (i-1)/mxp
         ix = i - mxp*(iy-1)
         d = (xd(ix)-x0)**2 + (yd(iy)-y0)**2
         if (d .lt. dmin) then
            dmin = d
            nearest = i
         endif
      enddo

      return
      end

c--------------------------------------
      subroutine blin_coef(iw)
c--------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension iw(1)
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      include 'comm_data.h'
      include 'comm_new.h'
      
      call bracket(mxp, xd, nxp, xm, iw)
      call bracket(myp, yd, nyp, ym, iw(nxp+1))
      
      do k = 1, nxyc
         j = 1 + (iox(k)-1)/nxp
         i = iox(k) - (j-1)*nxp
c.....find the i,j location for the four surrounding DATA grid points.
         i1 = iw(i)
         j1 = iw(nxp+j)
c.....x-sort index of four DATA points surrounding MODEL point (i,j).
         im2d(k) = i1 + (j1-1)*mxp

c.....find the interpolation ratios.
         fx = (xm(i)-xd(i1))/(xd(i1+1)-xd(i1))
         fy = (ym(j)-yd(j1))/(yd(j1+1)-yd(j1))

         blcf(k)        = (1.-fx)*(1.-fy)   
         blcf(k+nxyc)   = fx*(1.-fy)        
         blcf(k+2*nxyc) = (1.-fx)*fy        
         blcf(k+3*nxyc) = fx*fy             
      enddo

      return
      end

c     -----------------------------------------------------------------
      subroutine bracket(nx1,x1,nx2,x2,it)
c     -----------------------------------------------------------------
c     find the elements of x1 which bracket each element of x2.
c     returns it(i), for i=1,nx2 such that:
c          x1(it(i)) .le. x2(i)  .and.  x2(i) .le. x1(it(i)+1) 
c     nx1  = (input) length of x1.
c     x1   = (input) must have x1(i+1) .gt. x1(i), i=1,nx1-1.
c     nx2  = (input) length of x2.
c     x2   = (input) must have x2(i+1) .gt. x2(i), i=1,nx2-1.
c     it   = (output) nx2 indices of the lower side of the pair of
c            consecutive elements of x1 which bracket x2(i).
c
c     must input x1(1).le.x2(1) .and. x1(nx1).ge.x2(nx2).
c
      dimension x1(1),x2(1),it(1)
c
      i1 = 1
      do 20 i2=1,nx2
   10 if(x2(i2).ge.x1(i1) .and. x2(i2).le.x1(i1+1)) goto 20
      i1 = i1 + 1
      if(i1.lt.nx1-1) goto 10
   20 it(i2) = i1
      return
c     end of bracket.
      end

c----------------------------------------------------------------
      subroutine clim_updt(npt,nz,nstep, h0,sigma,dzin,hclf,tclf,sclf,dclf)
c----------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      dimension h0(1),hclf(npt,nz,1),tclf(npt,nz,1),sclf(npt,nz,1)
      dimension dclf(npt,nz),sigma(nz),dzin(nz+1)
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch

      if (icl_ts .ne. 2) return

      call it_catch (ntclm, tclm, nstep, it1, it2, clm_tscl)
      
c.....if we are still within bracketing months:      
      if (it2 .eq. iclm) return

      iclm = it2
      
      if (icl_h .eq. 2 ) then   !!..H-clim is time dependent
         do k = 1, nz           !!...save old time
            do i = 1, npt
               hclf(i,k,1) = hclf(i,k,2)
            enddo
         enddo
         
         if (icl_htop .eq. 1) 
     *   call read_zt (idf_hcl, lclm,npt, 1, it2, 'mltc', tp, hclf(1,1,2))
         
         sigk = sigma(3)
         do i = 1, npt
            hclf(i,2,2) = 0.5*hclf(i,1,2) + sigk*(z_begin - 1.5*hclf(i,1,2))
         enddo
         do k = 3, nsig - 1
            sigkp = sigma(k+1)
            do i = 1, npt
               hclf(i,k,2) = (sigk+sigkp) * (z_begin - 1.5*hclf(i,1,2))
            enddo
            sigk = sigkp
         enddo
         k = nsig
         do i = 1, npt
            hclf(i,k,2) = dzin(k+1) + sigma(k)*(z_begin - 1.5*hclf(i,1,2))
         enddo
      endif
      
      do k = 1, nz              !!...save old time
         do i = 1, npt
            tclf(i,k,1) = tclf(i,k,2)
         enddo
      enddo
      if (use_salt) then
         do k = 1, nz           !!...save old time
            do i = 1, npt
               sclf(i,k,1) = sclf(i,k,2)
            enddo
         enddo
      endif
      
      k2_h = 1
      if (icl_h .eq. 2) k2_h = 2
      call read_linz(idf_t, lclm, npt,mpack,nz,nzclm, it2,
     *               hclf(1,1,k2_h),tclf(1,1,2),zclm,tp, 'temp') 
         
      if (use_salt) then
         call read_linz(idf_s, lclm, npt,mpack,nz,nzclm, it2,
     *        hclf(1,1,k2_h),sclf(1,1,2),zclm,tp, 'salt') 
      endif

      if (ipre.eq.1) then
         if (use_salt) call potn_dens (npt,nzi,tclf(1,1,2),sclf(1,1,2),dclf) 
         call dconv_cl (npt,nz,nzi,hclf,tclf(1,1,2),sclf(1,1,2),dclf)
      endif
      
      return
      end


c----------------------------------------------------------------
      subroutine psi_updt(npt,nstep,psif)
c----------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      dimension psif(npt,1)

      if (icl_psi .ne. 2) return

      call it_catch (ntpsi, tpsi, nstep, it1, it2, psi_tscl)

      if (it2 .eq. ipsi) return

      ipsi = it2
      
      do i = 1, npt
         psif(i,1) = psif(i,2)
      enddo
         
      call read_zt (idf_psi, lpsi,npt, 1, it2, 'psi', tp, psif(1,2))
         
      return
      end

c-----------------------------------------------------------------------
      subroutine clim_relax(npt,nz,hmf,tmf,smf,hclf,tclf,sclf)
c-----------------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      dimension hmf(npt,1),tmf(npt,1),smf(npt,1),
     *          hclf(npt,nz,1),tclf(npt,nz,1),sclf(npt,nz,1)

      if (icl_rlx .eq. 0) return !! NO RELAXATION - EXIT

      if     (icl_h .eq. 1) then !! H-clim time independent
         do i = 1, npt
            coef = sponge(i)
            do k = 1, nzi(i)
               hmf(i,k) = hmf(i,k) - coef*(hmf(i,k)-hclf(i,k,1))
            enddo
         enddo
      elseif (icl_h .eq. 2) then !! h_clim time varying
         do i = 1, npt
            coef = sponge(i)
            if (coef .ne. 0.) then
               do k = 1, nzi(i)
                  hcl = hclf(i,k,1) + clm_tscl*(hclf(i,k,2) - hclf(i,k,1))
                  hmf(i,k) = hmf(i,k) - coef*(hmf(i,k) - hcl)
               enddo
            endif
         enddo
      endif
      
      if     (icl_ts .eq. 1) then 
         if (use_salt) then
            do i = 1, npt
               coef = sponge(i)
               if (coef .ne. 0.) then
                  do k = 1, nzi(i)
                     tmf(i,k) = tmf(i,k) - coef*(tmf(i,k)-tclf(i,k,1))
                     smf(i,k) = smf(i,k) - coef*(smf(i,k)-sclf(i,k,1))
                  enddo
               endif
            enddo
         else
            do i = 1, npt
               coef = sponge(i)
               if (coef .ne. 0.) then
                  do k = 1, nzi(i)
                     tmf(i,k) = tmf(i,k) - coef*(tmf(i,k)-tclf(i,k,1))
                  enddo
               endif
            enddo
         endif
         
      elseif (icl_ts .eq. 2) then !!...vary hmix/hthermo
         if (use_salt) then
            do i = 1, npt
               coef = sponge(i)
               if (coef .ne. 0.) then
                  do k = 1, nzi(i)
                     tcl = tclf(i,k,1) + clm_tscl*(tclf(i,k,2) - tclf(i,k,1))
                     scl = sclf(i,k,1) + clm_tscl*(sclf(i,k,2) - sclf(i,k,1))
                     tmf(i,k) = tmf(i,k) - coef*(tmf(i,k) - tcl)
                     smf(i,k) = smf(i,k) - coef*(smf(i,k) - scl)
                  enddo
               endif
            enddo
         else
            do i = 1, npt
               coef = sponge(i)
               if (coef .ne. 0.) then
                  do k = 1, nzi(i)
                     tcl = tclf(i,k,1) + clm_tscl*(tclf(i,k,2) - tclf(i,k,1))
                     tmf(i,k) = tmf(i,k) - coef*(tmf(i,k) - tcl)
                  enddo
               endif
            enddo
         endif
         
      endif

      return
      end
      
c-----------------------------------------------------------------------
      subroutine psi_relax(npt,pmf,psif,psib,nbx,lxx,nby,lyy)
c-----------------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      dimension pmf(npt),psif(npt,1),psib(npt),lxx(1),lyy(1)

      if (icl_psi .eq. 0) return

c  keep boundary conditions for psi:

      do i = 1, npt
         psib(i) = pmf(i)
      enddo

      if     (icl_psi .eq. 1) then 
         do i = 1, npt
c#            coef = 1.
            coef = clm_psi*sponge(i)
            pmf(i) = pmf(i) - coef*(pmf(i)-psif(i,1))
         enddo
      elseif (icl_psi .eq. 2) then 
         do i = 1, npt
            coef = clm_psi*sponge(i)
            p = psif(i,1) + psi_tscl*(psif(i,2) - psif(i,1))
            pmf(i) = pmf(i) - coef*(pmf(i) - tcl)
         enddo
      endif

c  restore boundary conditions for psi:
      do i = 1, nbx
         ib = lxx(i)
         pmf(ib) = psib(ib)
      enddo
      do i = 1, nby
         ib = lyy(i)
         pmf(ib) = psib(ib)
      enddo

      
      return
      end
      
c---------------------------------      
      subroutine afill(n, a, v)
c---------------------------------      
      dimension a(1)
      do i = 1, n
         a(i) = v
      enddo
      return
      end


c----------------------------------------------------------------------------- 
      subroutine read_linz(idf,key,NPT,MPT,NZ,MZ,it, hdat,fdat,zvert,fvert,tag)
c----------------------------------------------------------------------------- 
      implicit real(a-h,o-z),integer(i-n)
      dimension hdat(npt,1),fdat(npt,1), zvert(1),fvert(1)
      character*(*) tag
      include 'comm_new.h'
      include 'comm_data.h'

      dimension aa(npt,1), bb(mpt,1)
      pointer   (p_aa, aa), (p_bb, bb)
      
      if (key .eq. 0) then
         call mem_alloc(p_aa, MZ*npt, 2, 'AA space in read_linz')
      
         do k = 1, MZ
            call odb_rd1v3(idf, k, it, tag, aa(1,k)) 
         enddo

         do i = 1, npt 
            do k = 1, mz
               fvert(k) = aa(i,k) 
            enddo
            
            call zlin_intrp (i, npt,nz,mz, hdat,fdat,zvert,fvert)
         enddo

         call mem_free(p_aa, MZ*npt, 2)

      else
         call mem_alloc(p_bb, MZ*mpt, 2, 'BB space in read_linz')
      
         do k = 1, MZ
            call odb_rd1v3(idf, k, it, tag, bb(1,k))
         enddo

         call zlin_blin(NPT,MPT,NZ,MZ,ixd,im2d,blcf,bb,hdat,fdat,zvert,fvert)

         call mem_free(p_bb, MZ*mpt, 2)
      endif

      return
      end

c----------------------------------------------------------------------- 
      subroutine zlin_blin(NPT,MPT,NZ,MZ,ixd,im2d,blcf,aa,h,f,zval,fval)
c----------------------------------------------------------------------- 
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension ixd(1),im2d(1),blcf(npt,1)
      dimension aa(mpt,1), h(npt,1),f(npt,1), zval(1),fval(1)
      
      do i = 1, npt 
         i1 = im2d(i)
         n1 = ixd(i1)
         n2 = ixd(i1+1)
         n3 = ixd(i1+mxp)
         n4 = ixd(i1+mxp+1)

         b1 = blcf(i,1)
         b2 = blcf(i,2)
         b3 = blcf(i,3)
         b4 = blcf(i,4)
         do k = 1, mz
            fval(k) = b1*aa(n1,k) + b2*aa(n2,k) + b3*aa(n3,k) + b4*aa(n4,k) 
         enddo

         call zlin_intrp (i, npt,nz,mz, h,f,zval,fval)
      enddo

      return
      end

c------------------------------------------------------------------------
      subroutine blin_intr(npt, ixd, im2d, blcf, fd, f)
c------------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension ixd(1), im2d(1), blcf(npt,1), f(1), fd(1)
      include 'comm_new.h'

      do i = 1, npt
         i1 = im2d(i)
         f(i) = blcf(i,1)*fd(ixd(i1))     + blcf(i,2)*fd(ixd(i1+1))
     *        + blcf(i,3)*fd(ixd(i1+mxp)) + blcf(i,4)*fd(ixd(i1+mxp+1))
      enddo
      return
      end

c-------------------------------------------------------
      subroutine blin_indx (iseg)
c-------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension iseg(2,1)
      include 'comm_data.h'
      include 'comm_new.h'
      
c.....fill in ixd() according with the data compression iseg(2,mseg/2):      
      k = 0
      do i = 1, mseg/2
         do j = iseg(1,i), iseg(2,i)
            k = k + 1
            ixd(j) = k
         enddo
      enddo
c.....continue data to all points
      do k = 1, mxp*myp
         if (ixd(k) .eq. 0) ixd(k) = ixd(nearest(k, xd, yd, iseg))
      enddo

      return
      end
c-------------------------------------------------------------
      subroutine zlin_intrp(i, npt, nz, mz, h, f, zval, fval)
c-------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension h(npt,1), f(npt,1), zval(1), fval(1)
      
      zbot = zval(mz)
      fbot = fval(mz)

      mnext = 2
      scale = (fval(mnext)-fval(mnext-1))/(zval(mnext)-zval(mnext-1))
      shift = fval(mnext-1) - scale*zval(mnext-1)

      dlay = 0.5*h(i,1)
      zlay = dlay
      do k = 1, nz
         if (zlay .gt. zval(mnext)) then
            if (zlay .gt. zbot) then
               shift = fbot
               scale = 0.
            else
               do m = mnext+1, mz
                  if (zlay .le. zval(m)) then
                     scale = (fval(m) - fval(m-1))/(zval(m) - zval(m-1))
                     shift = fval(m-1) - scale*zval(m-1)                  
                     mnext = m
                     goto 100
                  endif 
               enddo
            endif
         endif
  100    f(i,k) = shift + scale * zlay
         dlay = h(i,k) - dlay
         zlay = zlay + 2.*dlay
      enddo

      return
      end



c-------------------------------------------------------------
      subroutine t_limit(npt, nzi, t)
c-------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension t(npt,1), nzi(npt)

      do i = 1, npt
         do k = 1, nzi(i)
            t(i,k) = max(-1.7,t(i,k))
         enddo
      enddo

      return
      end
dyn_glob.f/     842294936   1572  1572  100444  3158      `
      subroutine set_pbc (nxp, nyp, npbc, lpbcw, lpbce, mask)
c----------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      dimension lpbcw(1), lpbce(1), mask(nxp*nyp)

      npbc = 0
      do j = 1, nyp
         j1  = 1 + (j-1)*nxp
         jnx = j*nxp
         ierr = 0
         if ( mask(j1) .ne. 0 ) then
            if ( mask(jnx) .eq. 0 ) then
               ierr = nxp+1
            else   
               do i = 1, MINSEG - 1
                  if     (ierr.eq.0 .and. mask(j1+i).eq.0) then
                     ierr = i
                  elseif (ierr.eq.0 .and. mask(jnx-i).eq.0) then
                     ierr = nxp+1-i
                  endif
               enddo
            endif
            
            if (ierr .ne. 0) then
               write (6, *) 'A land is too close for PBC [i,j]=',ierr,j
               
            else
               npbc = npbc + 1
               lpbcw(npbc) = mask(j1)
               lpbce(npbc) = mask(jnx)
            endif
         endif
      enddo

      return
      end

c     ------------------------------------------------------------------
      subroutine set_bpx (nxp, nyp, mask, maxnb,minseg,nbx,lxx,snx)
c     ------------------------------------------------------------------
c     find the boundary indices for a x-sort in presence of periodic B.C..
c     a replacement for bound() in bndxy()
c     maxnb  = (input) max. storage space for lxx and snx.
c     minseg = (input) required minimum # of consecutive ocean points
c     nbx    = (output) # of x/y boundary indices of the x or y sort.
c     lxx    = (output) x or y bndry indices of a compressed x or y sort.
c     snx    = (output) nbx signs for the boundaries:=1 if the land -> ocean 
c
      implicit real(a-h,o-z),integer(i-n)
      character*72 msg
      dimension mask(nxp,1), lxx(1),snx(1)
      logical prev, curr
c
      nbx = 0
      do irow = 1, nyp
         prev = (mask(1, irow) .eq. 0)

         ista = 1
         do icol = 2, nxp
c            ista = 1
            ixy = mask(icol, irow)
            curr = (ixy .eq. 0)

            if ( curr .ne. prev ) then
               nbx = nbx + 1
               if (nbx .gt. MAXNB) then
                  write (msg, 101) MAXNB
 101              format ('set_pbx: insufficient space'
     *                    ' for lbx, inrease MAXNB=', i10, '$')
                  call perror1 (msg, 1)
               endif

               if ( prev ) then
                  lxx(nbx) = ixy
                  snx(nbx) = 1.
                  ista = icol
               else
                  if (icol-ista .lt. minseg) then
                     write (msg, 102) icol-ista, ista, irow
 102                 format ('set_bpx: only', i3, 
     *                    ' consecutive ocean grid pts',
     *                    ' next to (i,j)= ', 2i5, '$')
                     call perror1(msg, 1)
                  endif
                  lxx(nbx) = mask(icol-1, irow)
                  snx(nbx) = -1.
               endif

               prev = curr
            endif
         enddo
      enddo

c     end of set_bpx
      end
dyn_hflx.f/     842294936   1572  1572  100444  27731     `
c     -------------------------------------------------------------------------
      subroutine hflx_s89(tenso,npt,iox,t,tclim,cloudy,y,taux,tauy,q,qr,qb,tp)
c     -------------------------------------------------------------------------
c     update the model heat flux using the 1989 Seager et al. formulation.
c     t       = (input) model sst in degrees c.
c     cloudy  = (input) cloud cover as a fraction (0 to 1).
c     y       = (input) model grid latitudes in degrees.
c     q       = (output) heat flux.
      dimension iox(1),t(1),tclim(1),cloudy(1),y(1),taux(1),tauy(1),
     *          q(1),qr(1), qb(npt,1),tp(nyp,1)
      complex CPI18,EXLAT,EXPHI,EX2PHI

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /new_hfxevp/ trans_coef, QCON, rlx_time, solr_gamma, TATM, SATM
      save jmon

      parameter (RTODEG = 180./3.14159265)

      data TAUA/.017/,TAUCON/10300./,UVMIN/4.0/
      data cpi18 /(0.98481,-0.17365)/

c......for the tropic pacific:
       data al,acld /0.06,0.75/
       data aalpha,rh,asst,ct0 /0.0020,0.78,1.667,-5.0/
c......for the tropical atlantic:
c      data al,acld /0.06,0.66/
c      data aalpha,rh,asst,ct0 /0.0019,0.735,1.8,-5.0/

c.....parameter definitions:
c     rjuldy = julian day (0 = 1 jan).
c     uvmin  = minimum wind speed in m/s.
c     al     = albedo.
c     acld   = cloud coefficient.
c     aalpha = alpha coefficient.
c     rh     = pseudo relative humidity.
c     asst   = sst coefficient.
c     cto    = sst coefficient times offset.
c     cpi18  = cexp( (0,1)*(-pi/18.0) ).
c
c.....set constants used to find heat flux.
      a1mrh = 1.0 - rh
      a1mal = 1.0 - al
c.....get the current model time in julian days:
      call DayOfYear(tenso, juld, july)
      call enso2date(tenso, id,imon,iy)

      rjuldy = juld-1
      pha = 6.28318/real(july)

      phi     = pha*(rjuldy - 21.0)
      exphi   = cexp((0,1)*phi)
      cosphi  = real(exphi)
      sinphi  = aimag(exphi)
      ex2phi  = exphi**2
      cos2phi = real(ex2phi)
      sin2phi = aimag(ex2phi)
      arg = 23.45*sin((rjuldy-82.0)*pha)

c     the formulae from Weare 1980 are converted to w/m**2 and radians.
c     e.g. a1 from Weare is now a1=9.63 + 192.44*cos(rlat+90) and
c     in the calculatiion for the noon solar angle
c     alpha = arcsin(cos(rlat)*cos(arg1) + sin(rlat)*sin(arg1))
c           = arcsin(cos(rlat - arg1))
c           = arcsin(sin(rlat - arg1 + 90.)).
c
c.....compute the latitude dependent coefficients.
      do j = 1, nyp
         rlat = y(j)/rtodeg
         exlat = cexp((0,1)*rlat)
         cosrlat = real(exlat)
         sinrlat = aimag(exlat)

c........set the coefficients for the clear sky solar radiation function.
         a0 = -15.82 + 326.87*cosrlat
         a1 = 9.63 - 192.44*sinrlat
         b1 = -3.27 + 108.7*sinrlat
         a2 = -0.64 -7.8*real(exlat**2)
         b2 = -0.5 + 14.42*real((exlat**2)*cpi18)

c........tp(j,1) = q0 ! find q0, the clear sky radition.
         tp(j,1) = a0 + a1*cosphi + b1*sinphi + a2*cos2phi + b2*sin2phi

c........find alpha, the noon solar altitude or angle.
         alpha = arg - y(j) + 90.
         tp(j,2) = alpha
      enddo
c
c     this if statement is equivalent to arcsin(sin(x)) for the range
c     of alpha encountered.

      do 20 j = 1, nyp
   20 if(tp(j,2) .gt. 90.0) tp(j,2) = 180. - tp(j,2)

      taud2 = sqrt(TAUCON/TAUA)
      qcon_inv = 1. / qcon
      qcon_gam = SOLR_GAMMA / qcon

      cnst1 = 2500000.0 / 461.0
      cnst2 = 1.0 / 273.15
      cnst3 = 0.622*6.11
      cnst4 = 4.59373*a1mrh

c.....compute the heat flux.
      do k = 1, npt
         j = (iox(k)-1)/nxp + 1
         i = iox(k) - (j-1)*nxp
     
c........set a minimum wind speed of UVMIN(m/s) to avoid underestimate
c        of wind magnitude due to use of monthly averages.
         tc = amax1(taud2*(taux(k)**2 + tauy(k)**2)**.25, UVMIN)

         exparg = cnst1*(cnst2 - 1.0/(t(k)+273.15))
         qs     = cnst3 * exp(exparg)
         c      = a1mal*(1.0 - acld*cloudy(k) + aalpha*tp(j,2))

         qsolr   = c*tp(j,1)
         qb(k,1) = qsolr
 	 qr(k)   = qcon_gam * qsolr

	 qb(k,2) = cnst4 * tc * qs

 	 qb(k,3) = asst*t(k) + ct0

         qb(k,5) = 30.*(tclim(k)-t(k))                   

         qtot    = qsolr - qb(k,2) - qb(k,3)
         q(k)    = qcon_inv * qtot - qr(k)

c         if ( imon.ne.jmon .and. j.eq.nyp/2 .and. i.eq.nxp/2)  
c     *        write (2, '(1hq,i2,5(1pg12.4))') imon,qtot,qb(k,1),
c     *        qb(k,2), qb(k,3), qb(k,5)
      enddo

      jmon = imon

      return
      end

      subroutine hflx_s94 (npt, t, taux,tauy,sst,cld,solr, q,qr,qb)
c-------------------------------------------------------------------------
c     according to R.Seager & B.Blumental, December 1994, Journal of Climate.  
c     q = (output) heat flux = f(t,cld,solr) - gamma*solr
      dimension t(1),taux(1),tauy(1),sst(1),cld(1),solr(1),q(1),qr(1),qb(npt,1)

      common /new_hfxevp/ trans_coef, QCON, rlx_time, solr_gamma, TATM, SATM

      data TAUA/.017/,TAUCON/10300./,UVMIN/4.0/
      data AL,ALATENT,CE,RHOA/0.06,2.5e06,1.24e-03,1.225/
      data EPS,SIG,TSTA,D /0.97,5.6696e-08,0.71,0.78/
      data CP /1004/

      cnst1 = 0.622*6.112/1000.
      cnst2 = RHOA*CE*ALATENT*(1.- D)
      cnst3 = RHOA*CE*CP*TSTA
      cnst4 = D*1000./0.622
      cnst5 = EPS*SIG
      cnst6 = 4.*tsta

      taud2 = sqrt(TAUCON/TAUA)
      qcon_inv = 1./QCON
      qcon_gam = SOLR_GAMMA / QCON

      do i = 1, npt

c........Solar Radiation (for output only):
         qsol    = solr(i)
         qb(i,1) = qsol

c........Latent heat:
         wnsp = amax1(taud2*(taux(i)**2 + tauy(i)**2)**.25, UVMIN)
         qsat = cnst1*exp(17.67*t(i)/(t(i)+243.5))
         qlh = cnst2 * wnsp * qsat 
         qb(i,2) = qlh
         
c........Sensible heat:
         qsh = cnst3 * wnsp
         qb(i,3) = qsh
        
c........Long Wave Back Radiation:
         ts    = t(i) + 273.15
         sqeth = sqrt(cnst4 * qsat)
         ts3   = cnst5*ts*ts*ts
         cnst  = 0.8
         if( t(i) .gt. 28.) cnst = 0.4

         qlw = ts3*(ts*(1.-cnst*cld(i)**2)*(0.417-0.0486*sqeth) + cnst6)
         qb(i,4) = qlw

c........Heat Flux Deficit (for output only):
         qb(i,5) = 30.*(sst(i)-t(i))

c........The Total Heat Flux at the Surface:
         qr(i) = qcon_gam * qsol
         qtot  = qsol - qlh - qsh - qlw
c        
c........Since this is in W/m2, we need to convert it to dyn/m3
         q(i)  = qcon_inv * qtot - qr(i)
      enddo

      return
      end

c-------------------------------------------------------------------------
      subroutine hflx_s94b(npt, t, taux,tauy,sst,cld,solr, q,qr,qb)
c-------------------------------------------------------------------------
c     according to R.Seager & B.Blumental, December 1994, Journal of Climate.  
c     q = (output) heat flux = f(t,cld,solr) - gamma*solr
      dimension t(1),taux(1),tauy(1),sst(1),cld(1),solr(1),q(1),qr(1),qb(npt,1)

      common /new_hfxevp/ trans_coef, QCON, rlx_time, solr_gamma, TATM, SATM

      data TAUA/.017/,TAUCON/10300./,UVMIN/4.0/
      data AL,ALATENT,CE,RHOA/0.06,2.5e06,1.24e-03,1.225/
      data EPS,SIG,TSTA,D /0.97,5.6696e-08,0.71,0.78/
      data CP/1004/

      cnst1 = 0.622*6.112/1000.
      cnst2 = RHOA*CE*ALATENT
      cnst3 = RHOA*CE*CP*TSTA
      cnst4 = 1000./0.622
      cnst5 = EPS*SIG
      cnst6 = 4.*tsta

      taud2    = sqrt(TAUCON/TAUA)
      qcon_inv = 1./QCON
      qcon_gam = SOLR_GAMMA/QCON

      do i = 1, npt

c........Solar Radiation (for output only):
         qsol    = solr(i)
         qb(i,1) = qsol

c........Latent heat:
         wnsp = amax1(taud2*(taux(i)**2 + tauy(i)**2)**.25, UVMIN)
         qsat = cnst1*exp(17.67*t(i)/(t(i)+243.5))
         qair = (-9.42 + 0.97*t(i))/1000.
         qlh = cnst2 * wnsp * (qsat - qair) 
         qb(i,2) = qlh
         
c........Sensible heat:
         qsh = cnst3 * wnsp
         qb(i,3) = qsh
        
c........Long Wave Back Radiation:
         ts = t(i) + 273.15
         sqeth = sqrt(cnst4 * qair)
         ts3 = cnst5*ts*ts*ts
         cnst = 0.8 
         if( t(i) .gt. 28.) cnst = 0.4

         qlw = ts3*(ts*(1.-cnst*cld(i)**2)*(0.417-0.0486*sqeth) + cnst6)
         qb(i,4) = qlw

c........Heat Flux Deficit (for output only):
         qb(i,5) = 30.*(sst(i)-t(i))

c........The Total Heat Flux at the Surface:
         qr(i) = qcon_gam * qsol
         qtot  = qsol - qlh - qsh - qlw
c        
c........Since this is in W/m2, we need to convert it to dyn/m3
         q(i)  = qcon_inv * qtot - qr(i)
      enddo

      return
      end

c---------------------------------------------------------------------------
      subroutine init_pbl(npt, NX, NY, xm, ym, iox)
c---------------------------------------------------------------------------
      implicit real*4(a-h,o-z),integer(i-n)
      include 'comm_pbl.h'
      dimension iox(1), lsm1d(1), xm(nx), ym(ny)
      pointer (p_lsm1d, lsm1d)

      parameter (TORAD = 3.14159265/180., REARTH = 6378000.)

      nxy = nx*ny
      call mem_alloc (p_up,  nxy, 2, 'up')
      call mem_alloc (p_vp,  nxy, 2, 'vp')

      call mem_alloc (p_thv,  nxy, 2, 'thv')
      call mem_alloc (p_the,  nxy, 2, 'the')

      call mem_alloc (p_thve,  nxy, 2, 'thve')
      call mem_alloc (p_thvs,  nxy, 2, 'thvs')

      call mem_alloc (p_pnuxp,  nxy, 2, 'pnuxp')
      call mem_alloc (p_pnuyp,  nxy, 2, 'pnuyp')

      call mem_alloc (p_qe,  nxy, 2, 'qe')
      call mem_alloc (p_qs,  nxy, 2, 'qs')

      call mem_alloc (p_c0,  nxy, 2, 'c0')
      call mem_alloc (p_dx,  nxy, 2, 'dx')
      call mem_alloc (p_dy,  ny,  2, 'dy')

      call mem_alloc (p_lsm,  nxy,  1, 'lsm')

c  determine grid spacing in m

      ipbl_jsta = 0
      ipbl_jend = 0
      do j = 1, ny-1
         dy(j) = TORAD * REARTH * (ym(j+1)-ym(j))
         if (ipbl_jsta .eq. 0 .and. ym(j).gt.pbl_south) ipbl_jsta = j
         if (ipbl_jend .eq. 0 .and. ym(j).gt.pbl_north) ipbl_jend = j-1
         deg2met  = TORAD * REARTH * cos(TORAD * 0.5*(ym(j) + ym(j+1)))

         do i = 1, nx-1
            dx(i,j) = deg2met * (xm(i+1) - xm(i))
         enddo
         dx(nx,j) = dx(nx-1,j)
      enddo
      if (ym(1)  .ge. pbl_south) ipbl_jsta = 2
      if (ym(ny) .le. pbl_north) ipbl_jend = ny-1

      p_lsm1d = p_lsm
      do i = 1, npt
         lsm1d(iox(i)) = i
      enddo

      return
      end

c---------------------------------------------------------------------------
      subroutine htflux_pbl (npt,nx,ny, iox,xm,ym, sst,cldfr, wspd,u,v,
     *                       q,t, rlh,sh,qlw, qa,th)
c---------------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_pbl.h'
      
      dimension xm(nx), ym(ny), iox(1), idim(2)
      dimension sst(npt), cldfr(npt), wspd(npt), u(npt), v(npt), 
     *          qlw(npt), rlh(npt), sh(npt),
     *          q(nx,ny), t(nx,ny), th(nx,ny), qa(nx,ny)

      logical FIRST_PBL, ADVEC
      save    FIRST_PBL
      data    FIRST_PBL /.true./

      if ( FIRST_PBL ) then
         call init_pbl(npt, NX, NY, xm, ym, iox)
         FIRST_PBL = .false.
      endif

c  set model parameters:

      ADVEC = (ipbl_advec .eq. 1)
      pnu   = pbl_pnu
      delta = pbl_delta
      pml   = pbl_pml
      depth = pbl_depth
      betav = pbl_betav
      qrad  = pbl_grad / 86400.

c  set constants:

      r    = 287.04
      psfc = 100000.
      rl   = 2.5e+6
      cp   = 1004.
      rhoa = 1.225
      stef = 5.6696e-8
      eps  = 0.97

      idim(1) = nx
      idim(2) = ny

      jstart = ipbl_jsta
      jend   = ipbl_jend

c  Two iterations are performed.  A smaller exchange coefficient is
c  used on second iteration if mixed layer is stable.
c  First find equilibrium values of theta_V and q.  These are set to
c  their observed values over land.

      do 24 j = 1, ny
      do 24 i = 1, nx
         c0(i,j) = .0014 
         k = lsm(i,j)
         if (k .ne. 0) then 
            qs(i,j)=.622*6.11*exp(17.67*(1.-243.5/(sst(k)+243.5)))/1000.
         endif
   24 continue

      iter   = 1
      itermx = 3

   99 continue
      do 25 j=jstart,jend  
      do 25 i=1,nx

         if(iter.gt.1 .and. (thv(i,j).gt.thvs(i,j))) then
            c0(i,j)=.00075
         endif

         k = lsm(i,j)

         if (k .eq. 0) then
            thve(i,j) = (t(i,j)*(psfc/(psfc-.5*pml))**(r/cp))*(1.+.61*q(i,j))
            qe(i,j)   = q(i,j)
            th(i,j)   = t(i,j)
         else
            w0 = wspd(k)*pml/depth
            thvs(i,j) = (sst(k)+273.15) * (1.+.61*qs(i,j))
            thve(i,j) = thvs(i,j)+pml*qrad/((1.+betav)*c0(i,j)*w0)
            qe(i,j)   = qs(i,j)/(1.+delta)
         endif
 25   continue

c  Set equilibrium values to observed at northernmost and southernmost
c  points.  This is required because advection/diffusion cannot be computed
c  when there is no poleward point.  Actual values of air temperature and
c  air humidity are also set equal to observed values and used in flux
c  calculation.

      do 26 i=1,nx
         do 27 j=1,jstart
            up(i,j)=0.
            vp(i,j)=0.
            pnuxp(i,j)=0.
            pnuyp(i,j)=0.
            qe(i,j)=q(i,j)
            thve(i,j)=(t(i,j)*(1017./(1000.))**(r/cp))*(1.+.61*q(i,j))
            qa(i,j)=q(i,j)
            thv(i,j)=thve(i,j)
            th(i,j)=t(i,j)*(1017./(1000.))**(r/cp)
   27    continue
         do 26 j=jend,ny
            up(i,j)=0.
            vp(i,j)=0.
            pnuxp(i,j)=0.
            pnuyp(i,j)=0.
            qe(i,j)=q(i,j)
            thve(i,j)=(t(i,j)*(1017./(1000.))**(r/cp))*(1.+.61*q(i,j))
            qa(i,j)=q(i,j)
            thv(i,j)=thve(i,j)
            th(i,j)=t(i,j)*(1017./(1000.))**(r/cp)
 26   continue
      
c  Set diffusion and advecting wind speed.  Over land both are
c  set to zero to ensure derived theta_V and q are observed 
c  values.  In addition, diffusion is set to zero close to 
c  coastline.  

      do 29 j=jstart,jend
      do 29 i=1,nx

         k = lsm(i,j)

         if ( k .eq. 0 ) then 
            up(i,j)    = 0.
            vp(i,j)    = 0.
            pnuxp(i,j) = 0.
            pnuyp(i,j) = 0.
         else
            w0=wspd(k)*pml/depth

            ip1=i+1
            if(ip1.eq.(nx+1)) ip1=nx
            ip2=i+2
            if(ip2.eq.(nx+2) .or. ip2.eq.(nx+1)) ip2=nx
            im1=i-1
            if(im1.eq.0) im1=1
            im2=i-2
            if(im2.eq.0 .or. im2.eq.-1) im2=1
            jm1=j-1
            jm2=j-2
            if(jm2.eq.0) jm2=1
            jp1=j+1
            jp2=j+2

            if(jp2.eq.(ny+1)) jp2=ny 

            if( lsm(ip1,j) + lsm(im1,j) + lsm(i,jp1) + lsm(i,jm1) +
     *          lsm(ip2,j) + lsm(im2,j) + lsm(i,jp2) + lsm(i,jm2) .eq. 0 ) then
               pnuxp(i,j)=0.
               pnuyp(i,j)=0.
            else
               if(i.eq.1 .or. i.eq.nx) then
                  twodx2=dx(i,j)**2.
               else
                  twodx2=.25*(dx(i,j)+dx(i+1,j))**2.
               endif
               pnuxp(i,j)=pnu*pml/((1.+betav)*c0(i,j)*w0*twodx2)
               pnuyp(i,j)=pnu*pml/((1.+betav)*c0(i,j)*w0*.25*
     $              (dy(j)+dy(j-1))*(dy(j)+dy(j-1)))
            endif 

            if ( advec ) then
               if (up(i,j) .gt. 0.) then
                  i1=i
               else
                  i1=i+1
                  if (i.eq.nx) i1=nx
               endif

               up(i,j) = u(k)*pml/((1.+betav)*c0(i,j)*w0*dx(i1,j))

               if (v(k) .gt. 0.) then
                  vp(i,j) = v(k)*pml/((1.+betav)*c0(i,j)*w0*dy(j-1))
               else
                  vp(i,j) = v(k)*pml/((1.+betav)*c0(i,j)*w0*dy(j))
               endif
            else
               up(i,j)=0.
               vp(i,j)=0.
            endif
         endif
   29 continue

c  call subroutine that solves for theta_V

      call adv2Deq1(idim,up,vp,pnuxp,pnuyp,thve,thv)


c  repeat one time

      iter=iter+1

      if(iter.lt.itermx) goto 99

c  set scaled advecting velocities for humidity calculation and
c  impose no diffusion across continental boundaries


      do 39 j=jstart,jend
      do 39 i=1,nx
         k = lsm(i,j)
         if (k .ne. 0) then 
            w0=wspd(k)*pml/depth

            ip1=i+1
            if(ip1.eq.(nx+1)) ip1=nx
            ip2=i+2
            if(ip2.eq.(nx+2) .or. ip2.eq.(nx+1)) ip2=nx
            im1=i-1
            if(im1.eq.0) im1=1
            im2=i-2
            if(im2.eq.0 .or. im2.eq.-1) im2=1
            jm1=j-1
            jm2=j-2
            if(jm2.eq.0) jm2=1
            jp1=j+1
            jp2=j+2

            if(jp2.eq.(ny+1)) jp2=ny 

            if( lsm(ip1,j) + lsm(im1,j) + lsm(i,jp1) + lsm(i,jm1) +
     *          lsm(ip2,j) + lsm(im2,j) + lsm(i,jp2) + lsm(i,jm2) .eq. 0 ) then
               pnuxp(i,j)=0.
               pnuyp(i,j)=0.
            else
               if(i.eq.1 .or. i.eq.nx) then
                  twodx2=dx(i,j)**2.
               else
                  twodx2=.25*(dx(i,j)+dx(i+1,j))**2.
               endif
               pnuxp(i,j)=pnu*pml/((1.+delta)*c0(i,j)*w0*twodx2)
               pnuyp(i,j)=pnu*pml/((1.+delta)*c0(i,j)*w0*.25*(dy(j)+dy(j-1))*
     $              (dy(j)+dy(j-1)))
            endif
            if(advec) then
               if(up(i,j).gt.0.) then
                  i1=i
               else
                  i1=i+1
                  if(i.eq.nx) i1=nx
               endif
               up(i,j)=u(k)*pml/((1.+delta)*c0(i,j)*w0*dx(i1,j))
               if(v(k).gt.0.) then
                  vp(i,j)=v(k)*pml/((1.+delta)*c0(i,j)*w0*dy(j-1))
               else
                  vp(i,j)=v(k)*pml/((1.+delta)*c0(i,j)*w0*dy(j))
               endif
            else
               up(i,j)=0.
               vp(i,j)=0.
            endif
         endif
 39   continue
      
c  call solver to derive q 

      call adv2Deq1(idim,up,vp,pnuxp,pnuyp,qe,qa)

c  calculate theta from theta_V and q
c  calculate fluxes of sensible and latent heat

      do j = 1, ny
      do i = 1, nx
         k = lsm(i,j)
         if ( k .ne. 0 ) then
            th(i,j) = thv(i,j) / (1.+.61*qa(i,j))
            co1  = rhoa * c0(i,j) * wspd(k)
            sstk = sst(k) + 273.15
            co2  = sstk - th(i,j)
            co3  = eps*stef*sstk*sstk*sstk

            rlh(k) = co1*rl*(qs(i,j)-qa(i,j))
            sh(k)  = co1*cp*co2

c            qlw(k) = eps*stef*(th(i,j)**4.)*(.39-.05*sqrt(qa(i,j)*1000./.622))
c     *           *(1.-.55*cldfr(k)) + 4.*eps*stef*(th(i,j)**3.)*co2

            if ( sstk .gt. 301.15 ) then
               aout =.4
            else
               aout =.8
            endif
            qlw(k) = co3 * ( sstk * (.417-.0486*sqrt(qa(i,j)*1000./.622)) *
     *           (1. - aout*cldfr(k)*cldfr(k)) + 4.*co2)
         endif
      enddo
      enddo

      return
      end

c  This subroutine computes surface fluxes of latent and sensible heat 
c  in units of W/m^2.  The fluxes are computed by a forced advection-
c  diffusion equation.  It solves a equations for the virtual potential
c  temperature and the air humidity and then inverts the first to get
c  the air temperature.  In both case the balance is one of diffusion,
c  horizontal advection, surface fluxes and a flux at the mixed layer top.
c  The mixed layer is a constant depth.
c
c  The model also computes long wave cooling with the Berliand and
c  Berliand bulk formula (see Seager and Blumenthal, J. Climate, Dec '94
c  for example).
c
c  Note added 11/7/94:  To date the model has been coupled to an ocean
c  GCM developed by Ragu Murtugudde, now at GSFC.  The results have
c  been good.  Some care is needed at open ocean boundaries it turns out.
c  In the version as I give it here you will see the computation is done
c  only for meridional index j=jstart,jend with jstart=25 and jend =ny-1.
c  This is like putting a boundary in the middle of the southern ocean.
c  For points poleward of the end points the air humidity and temperature
c  are set equal to observed values ensuring that values advected in are
c  realistic.  We used ECMWF data at 1000mb.  We found that the air-sea
c  temperature difference given by this data was too large (probably 
c  'cos the SLP is greater than the lowest ananlysis level of 1000mb) so
c  we correct it to by a dry adiabaltic lapse rate to an slp of 1017 mb
c  which corresponded to a reasonable SLP at 40S which is where our ocean
c  GCM began.  Clearly users are free to do whatever they want but 
c  *be cautious*!.
c
c  The limits are to set jstart =2 and jend=ny-1.  The end points cannot be
c  included because of the diffusion operator that would otherwise look
c  out of array bounds.
c
c  The inputs are:
c
c  sst  = array containing the model or observed SST
c  u    = array containing observed low level zonal wind velocity
c  v    = array containing observed low level meridional wind velocity
c  wspd = array containing observed low level wind speed
c  lsm  = a land sea mask (1=land, 0= ocean)
c  q    = observed low level air humidity (kg/kg)
c  t    = observed low level temperature (K)
c  cldfr= observed cloud cover
c  wlat = western latitude of input grid, in degree (e.g. 220.)
c  slat = southern latitude of input grid, in degrees (e.g. -30.)
c  dxd  = grid spacing in degrees longitude.  dxd(i) equals the distance from
c         the longitude at i-1 to the longitude at i which allows for 
c         uneven grid spacing.
c  dyd  = grid spacing in degrees latitude.  dyd(j) equals the distance from
c         the latitude at j to the latitude at j+1 which allows for 
c         uneven grid spacing.
c  nx   = number of x grid points 
c  ny   = number of y grid points
c
c
c  The outputs are:
c
c  sh  = array containing the sensible heat flux (W/m^2)
c  rlh = array containing the latent heat flux (W/m^2)
c  qa  = atmospheric mixed layer humidity in kg/kg
c  th  = atmospheric mixed layer potential temperature in K
c  qlw = longwave radiative heat flux
c
c  Parameters are:
c
c  pnu=diffusivity (m^2/s)
c  delta - equilibrium q = q0/(1+delta) where q0 is saturation humidity
c          at the SST
c  pml=pressure depth (Pa) of the mixed layer
c  depth=geometric depth of mixed layer = (pml/(rhoa*grav)
c  qrad=radiative cooling K/s
c  betav=ratio of downward theta_V flux at mixed layer top to the
c        surface flux
c  c0=surface exchange coefficient
 








      SUBROUTINE adv2Deq1(p,UP,VP,NUXP,NUYP,QE,QA)
 
      STRUCTURE /advqS/
          INTEGER NX
          INTEGER NY
      END STRUCTURE
      RECORD /advqS/ p
 
      REAL UP(p.NX,p.NY),VP(p.NX,p.NY), QE(p.NX,p.NY)
      REAL NUXP(p.NX,p.NY),NUYP(p.NX,p.NY)
      REAL  QA(p.NX,p.NY)
 
C       variables are dimensioned with X first
      NXSKP = 1
      NYSKP = p.NX
 
C       does X advection
C       loops over all latitudes
      IX = 1
      DO IY = 1 , p.NY
         CALL ADVDIFQ1DX(UP(1,IY),NUXP(1,IY),p.NX,QE(1,IY),QE(1,IY),
     *        QE(p.NX,IY),QA(1,IY))
 
      END DO
C       does Y advection
C       loops over all longitudes
      IY = 1
      DO IX = 1 , p.NX
C               boundary conditions
         QLEFT = QE(IX,1)
         QRIGHT = QE(IX,p.NY)
         CALL ADVDIFQ1D(VP(IX,1),NUYP(IX,1),p.NY,QA(IX,1),
     *        QLEFT,QRIGHT,NYSKP,QA(IX,1))
      END DO
 
      RETURN
      END

      SUBROUTINE ADVDIFQ1DX(U2,NU2,NX,QE0,QLEFT,QRIGHT,QA)
      REAL U2(NX), NU2(NX),QE0(NX), QA(NX), QLEFT, QRIGHT
      INTEGER NX
 
      PARAMETER (MAXDIM=800)
      REAL*4    AC(MAXDIM),BC(MAXDIM),CC(MAXDIM),QE(MAXDIM)
*       AUTOMATIC AC,BC,CC,QE
 
      IF(NX.GT.MAXDIM)STOP 12
C       does inside points
      NXL1 = NX - 1
      DO K = 2 , NXL1
         QE(K) = QE0(K)
         IF(U2(K).GE.0) THEN
            AC(K) = -U2(K) - NU2(K)
            BC(K) = 1. + U2(K) + 2*NU2(K)
            CC(K) = -NU2(K)
         ELSE
C               wind blows left
            AC(K) = -NU2(K)
            BC(K) = 1. - U2(K) + 2*NU2(K)
            CC(K) = U2(K) - NU2(K)
         ENDIF
      END DO
 
C       does left point
      IF(U2(1).GT.0.0)THEN
C               boundary condition matters
         QE(1) = QE0(1) + U2(1)*QLEFT
         BC(1) = 1. + U2(1)
         CC(1) = 0.0
      ELSE
C               boundary condition doesn't matter
         QE(1) = QE0(1)
         BC(1) = 1. - U2(1)
         CC(1) = U2(1)
      ENDIF
 
C       does right point
      IF(U2(NX).GT.0.0)THEN
C               boundary condition doesn't matter
         QE(NX) = QE0(NX)
         BC(NX) = 1. + U2(NX)
         AC(NX) = -U2(NX)
      ELSE
C               boundary condition matters
         QE(NX) = QE0(NX) - U2(NX)*QRIGHT
         BC(NX) = 1.0 - U2(NX)
         AC(NX) = 0.0
      ENDIF
      CALL TRIDAGQA(AC,BC,CC,QE,CC,QE,QA,1,NX)
      RETURN
      END
C \end{fortran}
C \subsection{advq1d}
C  
C Inputs
C \begin{variablelist}
C   \v U      U    scaled version of $U = (Hu)/(C_e |v| dx)$
C   \v NX      n_x number of points
C   \v QE      q_e equilibrium (forcing) Q
C   \v QLEFT   {}  Qa beyond the left boundary
C   \v QRIGHT  {}  Qa beyond the right boundary
C   \v NXSKP   {}  integer spacing between consecutive elements of QA
C \end{variablelist}
C  
C Output
C \begin{variablelist}
C   \v QA      q_a solution for QA
C \end{variablelist}
C \begin{fortran}
      SUBROUTINE ADVDIFQ1D(U2,NU2,NX,QE0,QLEFT,QRIGHT,NXSKP,QA)
      REAL U2(NXSKP,NX), QE0(NXSKP,NX), QA(NXSKP,NX), QLEFT, QRIGHT
      REAL NU2(NXSKP,NX)
      INTEGER NX
 
      PARAMETER (MAXDIM=800)
      REAL*4    AC(MAXDIM),BC(MAXDIM),CC(MAXDIM),QE(MAXDIM)
*       AUTOMATIC AC,BC,CC,QE
 
      IF(NX.GT.MAXDIM)STOP 12
C       does inside points
      NXL1 = NX - 1
      DO K = 2 , NXL1
         QE(K) = QE0(1,K)
         IF(U2(1,K).GE.0) THEN
            AC(K) = -U2(1,K) - NU2(1,K)
            BC(K) = 1. + U2(1,K) + 2*NU2(1,K)
            CC(K) = - NU2(1,K)
         ELSE
C               wind blows left
            AC(K) = -NU2(1,K)
            BC(K) = 1. - U2(1,K) + 2*NU2(1,K)
            CC(K) = U2(1,K)-NU2(1,K)
         ENDIF
      END DO
 
C       does left point
      IF(U2(1,1).GT.0.0)THEN
C               boundary condition matters
         QE(1) = QE0(1,1) + U2(1,1)*QLEFT
         BC(1) = 1. + U2(1,1)
         CC(1) = 0.0
      ELSE
C               boundary condition doesn't matter
         QE(1) = QE0(1,1)
         BC(1) = 1. - U2(1,1)
         CC(1) = U2(1,1)
      ENDIF
 
C       does right point
      IF(U2(1,NX).GT.0.0)THEN
C               boundary condition doesn't matter
         QE(NX) = QE0(1,NX)
         BC(NX) = 1. + U2(1,NX)
         AC(NX) = -U2(1,NX)
      ELSE
C               boundary condition matters
         QE(NX) = QE0(1,NX) - U2(1,NX)*QRIGHT
         BC(NX) = 1.0 - U2(1,NX)
         AC(NX) = 0.0
      ENDIF
      CALL TRIDAGQA(AC,BC,CC,QE,CC,QE,QA,NXSKP,NX)
      RETURN
      END
C \end{fortran}
C \subsection{tridagqa}
C Same as tridag2 in the multiple mode linear equatorial model.  Solves
C a tridiagonal system.
C \begin{fortran}
C
      SUBROUTINE TRIDAGQA(A,B,C,D,E,F,X,NXSKP,N)
 
        PARAMETER (JS=1)
C
C     SOLVES THE TRIDIAGONAL SYSTEM
C        A(I)*X(I-1)+B(I)*X(I)+C(I)*X(I+1)=D(I)...I=JS,N  A(JS)=0,C(N)=0
C       solves in two passes
C       pass1   computes E(i), F(i) such that x(i) = E(i)*x(i+1) + F(i)
C       pass2   computes x(i) from E(i), F(i)
 
C     array C can be used as E
C     array D can be used as F
C
      DIMENSION A(*), B(*), C(*), D(*), E(*), F(*), X(NXSKP,*)
C
      E(JS) = C(JS) / B(JS)
      F(JS) = D(JS) / B(JS)
C
      JN = JS + 1
 
      DO 10 I = JN, N
        DN   = B(I) - A(I) * E(I-1)
        E(I) = C(I) / DN
        F(I) = ( D(I) - A(I) * F(I-1) ) / DN
10    CONTINUE
 
      X(1,N) = F(N)
        XOLD = F(N)
        IMAX = N-1
      DO 20 I =  IMAX,JS,-1
         XOLD = F(I) - E(I) * XOLD
         X(1,I) = XOLD
20    CONTINUE
 
      RETURN
      END
C \end{fortran}
C \end{document}

dyn_ice.f/      845476196   1572  1572  100444  4157      `
        subroutine link2htfluxice(npt, nx, ny, iox, xm, ym, tstep,
     *                        sst, cldfr, wspd, u, v,
     *                        q, t, rlh, sh, qlw, qa, th, rh, 
     *                        sss, qisw, ppi, qsw, pp, qios, brne,
     *                        hice, cice, thice, tsnw, rlhi, shi, qlwi, qswi)
	include 'comm_amlice.h'
	include 'amlice.h'
	dimension xm(nx), ym(ny), iox(1)
	dimension sst(npt), cldfr(npt), wspd(npt), u(npt), v(npt), 
     *       q(nx,ny), t(nx,ny), rlh(npt), sh(npt), qlw(npt),
     *       qa(nx,ny), th(nx,ny), rh(nx,ny),
     *       sss(npt), qisw(npt), ppi(npt), qsw(npt), pp(npt), 
     *       qios(npt), brne(npt),
     *       hice(npt), cice(npt), thice(npt), tsnw(nx,ny), 
     *       rlhi(nx,ny), shi(nx,ny), qlwi(nx,ny), qswi(nx,ny)
	
	logical FIRST_PBL
	save    FIRST_PBL
	data    FIRST_PBL /.true./

	if ( FIRST_PBL ) then
	   call init_amlice(npt, NX, NY, xm, ym, iox, slat)
	   do j = 1, ny
	      do i = 1, nx
                 tsnw(i,j) = tfreeze
		 lsm_aml(i,j) = 1
		 k = lsm(i,j)
		 if (k.ne.0) then
		    lsm_aml(i,j) = 0
		 endif
	      enddo
	   enddo
	   FIRST_PBL = .false.
	endif
	
	do j = 1, ny
	   do i = 1, nx
	      k = lsm(i,j)
	      if (k.ne.0) then
		 aml_cice(i,j) = cice(k)
		 aml_hice(i,j) = hice(k)
		 aml_thice(i,j) = thice(k)
		 aml_sst(i,j) = sst(k) + 273.15
		 aml_cldf(i,j) = cldfr(k)
		 aml_wspd(i,j) = wspd(k)
		 aml_u(i,j) = u(k)
		 aml_v(i,j) = v(k)
		 aml_sss(i,j) = sss(k)
		 aml_qisw(i,j) = qisw(k)
		 aml_ppi(i,j) = ppi(k)
	      endif
	   enddo
	enddo

	call htfluxice(nx,ny,nx,ny,lsm_aml,dxd,dyd,slat,tstep,
     +         aml_sst,aml_cldf,aml_wspd,aml_u,aml_v,q,t,
     +         aml_rlh,aml_sh,aml_qlw,aml_qsw,aml_pp,qa,th,rh,
     +         aml_sss,aml_qisw,aml_ppi,aml_hice,aml_cice,aml_thice,
     +         tsnw,aml_qios,aml_brne,rlhi,shi,qlwi,qswi,
     +         rlc0ice,cpc0ice,qlwice1,qlwice2)

c   call ice_pressure and forcing  here

	do j = 1, ny
	   do i = 1, nx
	      k = lsm(i,j)
	      if (k.ne.0) then
		 cice(k) = aml_cice(i,j)
		 hice(k) = aml_hice(i,j)
		 thice(k) = aml_thice(i,j)
		 rlh(k) = aml_rlh(i,j)
		 sh(k) = aml_sh(i,j) 
		 qlw(k) = aml_qlw(i,j) 
		 qsw(k) = aml_qsw(i,j) 
		 pp(k) = aml_pp(i,j) 
		 qios(k) = aml_qios(i,j)
		 brne(k) = aml_brne(i,j)
	      endif
	   enddo
	enddo
	
	return
	end
         
c---------------------------------------------------------------------------
	subroutine init_amlice(npt, NX, NY, xm, ym, iox, slat)
c---------------------------------------------------------------------------
	dimension iox(npt), lsm1d(1), xm(nx), ym(ny)
	pointer (p_lsm1d, lsm1d)
	include 'comm_amlice.h'
	
	nxy = nx*ny
	call mem_alloc (p_aml_cice,  nxy, 2, 'aml_cice')
	call mem_alloc (p_aml_hice,  nxy, 2, 'aml_hice')
	call mem_alloc (p_aml_thice,  nxy, 2, 'aml_thice')

	call mem_alloc (p_aml_sst,  nxy, 2, 'aml_sst')
	call mem_alloc (p_aml_sss,  nxy, 2, 'aml_sss')
	call mem_alloc (p_aml_u,  nxy, 2, 'aml_u')
	call mem_alloc (p_aml_v,  nxy, 2, 'aml_v')
	call mem_alloc (p_aml_cldf,  nxy, 2, 'aml_cldf')
	call mem_alloc (p_aml_wspd,  nxy, 2, 'aml_wspd')
	call mem_alloc (p_aml_qisw,  nxy, 2, 'aml_qisw')
	call mem_alloc (p_aml_ppi,  nxy, 2, 'aml_ppi')
	call mem_alloc (p_aml_rlh,  nxy, 2, 'aml_rlh')
	call mem_alloc (p_aml_sh,  nxy, 2, 'aml_sh')
	call mem_alloc (p_aml_qlw,  nxy, 2, 'aml_qlw')
	call mem_alloc (p_aml_qsw,  nxy, 2, 'aml_qsw')
	call mem_alloc (p_aml_pp,  nxy, 2, 'aml_pp')
	call mem_alloc (p_aml_qios,  nxy, 2, 'aml_qios')
	call mem_alloc (p_aml_brne,  nxy, 2, 'aml_brne')
	
	call mem_alloc (p_lsm,      nxy,  1, 'lsm')
	call mem_alloc (p_lsm_aml,  nxy,  1, 'lsm_aml')
	call mem_alloc (p_dxd,      nxy,  1, 'dxd')
	call mem_alloc (p_dyd,       ny,  1, 'dyd')

	call mem_alloc (p_rlc0ice,   nxy,  2, 'rlc0ice')
	call mem_alloc (p_cpc0ice,   nxy,  2, 'cpc0ice')
	call mem_alloc (p_qlwice1,   nxy,  2, 'qlwice1')
	call mem_alloc (p_qlwice2,   nxy,  2, 'qlwice2')

	slat = ym(1)
	do j = 1, ny-1
	   dyd(j) = ym(j+1) - ym(j)
	   do i = 2, nx
	      dxd(i,j) = xm(i) - xm(i-1)
	   enddo
	   dxd(1,j) = dxd(2,j)
	enddo
	
	p_lsm1d = p_lsm
	do i = 1, npt
	   lsm1d(iox(i)) = i
	enddo
	
	return
	end


dyn_io.f/       847481470   1572  1572  100666  40038     `
#define ITYPE_RST 0
#define MACHINE_WORD 4
#define c_str(s) ('s\0')

      subroutine init_rstrt (nxp, nyp, nz, npt, zin, iseg)
c---------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      character*100 str
      common /run/   nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast
      common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100)
      dimension   zin(1), zz(50), iseg(1)

      equivalence (inf(20),kd_sta),
     *            (inf(21),kd_xy),  (inf(22),kd_z),  (inf(23),kd_time), 
     *            (inf(24),kd_seg), (inf(25),kd_uv), (inf(26),kd_temp), 
     *            (inf(27),kd_salt),(inf(28),kd_tr), (inf(29),kd_phi), 
     *            (inf(30),kd_conv), (inf(31),kd_means),
     *            (inf(32),kd_psi), (inf(33),kd_ice),
     *            (inf(100),kd_end)

      call opda (1, 1, fbo(1:n_out))

      do i = 1, 100
         inf(i) = 0
         rnf(i) = 0.
      enddo

      iword   = MACHINE_WORD
      
      kd = iword * 200
      str = 'Resrart file for '//finp(1:mlen(finp)) 
      call wrda (1, 1, kd, len(str), str)

      kd = iword * 200 + 100
      kd_sta = kd
      kd_xy  = kd
      call wrda (1, iword, kd, nxp, xm) 
      call wrda (1, iword, kd, nyp, ym) 

      kd_z = kd
      do i = 1, nz
         zz(i) = -zin(i)
      enddo
      call wrda (1, iword, kd, nz, zz) 

      call segm_from_iox (npt, nseg, iox, iseg)
      kd_seg = kd
      call wrda (1, iword, kd, 2*nseg, iseg) 
      
      kd_uv = kd

      nstart     = 1
      nlaststart = 1
      nlast      = nsteps
      nscpu = 0
      nswll = 0

      inf(1) = 120
      inf(2) = nxp
      inf(3) = nyp
      inf(4) = nz
      inf(5) = 1
      inf(6) = npt
      inf(7) = nseg
      inf(8) = ntrac

      inf(11) = nstart

      inf(15) = nlaststart
      inf(16) = nsteps
      inf(17) = nlast

      rnf(1) = delt
      rnf(2) = enso_start
      rnf(3) = enso_scale
      rnf(4) = rnf(2)

      return
      end

      subroutine read_rstrt (nxp, nyp, nz, npt)
c--------------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      common /run/   nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast
      common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100)

      equivalence (inf(20),kd_sta),
     *            (inf(21),kd_xy),  (inf(22),kd_z),  (inf(23),kd_time), 
     *            (inf(24),kd_seg), (inf(25),kd_uv), (inf(26),kd_temp), 
     *            (inf(27),kd_salt),(inf(28),kd_tr), (inf(29),kd_phi), 
     *            (inf(30),kd_conv), (inf(31),kd_means),
     *            (inf(32),kd_psi), (inf(33),kd_ice),
     *            (inf(100),kd_end)

      iword = MACHINE_WORD
      
      call opda (1, 0, fbi(1:n_in))
      kd = 0
      call rdda (1, iword, kd, 100, inf) 
      kd = irdda (iword, 100, rnf) 

      ntype = idig(inf(1),1)
      if (ntype .ne. ITYPE_RST) then
         write (6, *) 'The file <' ,fbi(1:n_in),'> is not a RESTART-TYPE one !!'
         stop
      endif
      
      if (nxp.ne.inf(2) .or. nyp.ne.inf(3) .or.
     *     nz.ne.inf(4) .or. npt.ne.inf(6) ) then
         write(6,*)'The model dimensions are different from the restart data!'
         stop
      endif

      nptz   = inf(4)*inf(6)
      mtra   = inf(8)

      nstart = inf(11)
      nruns  = inf(12)
      nscpu  = inf(13)
      nswll  = inf(14)

      if (irest .eq. 1) then
         nlaststart = inf(15)
      else
         nlaststart = nstart
      endif
      nlast = nlaststart + nsteps - 1

      enso_start = rnf(2)
      rnf(4) = rnf(2) + rnf(3)*nstart

      if (irest .ne. 3) then
         ekf1 = rnf(10)
         epf1 = rnf(11)
         hcf1 = rnf(12)
         wcf1 = rnf(13)
         vlf1 = rnf(14)
         do k = 1, inf(4)+1
            hsave(k) = rnf(20+k)
         enddo
      endif

      kd = kd_uv
      call rdda (1, iword, kd, nptz, u) 
      kd = irdda (iword, nptz, v) 
      kd = irdda (iword, nptz, uc) 
      kd = irdda (iword, nptz, vc) 
      kd = irdda (iword, nptz, h) 
      
      if (kd_temp .ne. 0) then
         kd = kd_temp
         call rdda (1, iword, kd, nptz, t) 
      endif
      if (ibaro.ne.0.and.kd_psi .ne. 0) then
         kd = kd_psi
         call rdda (1, iword, kd, npt, psi) 
      endif
      if (use_ice .and. kd_ice .ne. 0) then
         kd = kd_ice
         call rdda (1, iword, kd, npt, hice) 
         kd = irdda (iword, npt, cice) 
         kd = irdda (iword, npt, thice) 
      endif
      if (use_salt .and. kd_salt .ne. 0) then
         kd = kd_salt
         call rdda (1, iword, kd, nptz, sal) 
         kd = irdda (iword, nptz, dens) 
      endif
      if (use_trac .and. kd_tr .ne.   0) then
         kd = kd_tr
         call rdda (1, iword, kd, nptz*mtra, tr) 
      endif
      if (kd_conv .ne. 0) then 
         kd = kd_conv
         call rdda (1, iword, kd, nptz, convn)
      endif

      if (kd_means .ne. 0) then
         kd = kd_means
         call rdda (1, iword, kd, nptz, um)
         kd = irdda (iword, nptz, vm)
         kd = irdda (iword, nptz, tm)
         if (use_salt .and. kd_salt .ne. 0) then
            kd = irdda (iword, nptz, salm) 
            kd = irdda (iword, nptz, densm) 
         endif
         if (use_trac .and. kd_tr .ne. 0) kd = irdda (iword, nptz*mtra, trm)
      endif
      
      call clda(1)

      call opda (1, 1, fbo(1:n_out))
      inf(8)  = ntrac
      inf(12) = nruns + 1
      inf(15) = nlaststart
      inf(16) = nsteps
      inf(17) = nlast

      rnf(1) = delt

      return
      end

      subroutine keep_rstrt (nstep, nskip)
c--------------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100)
      equivalence (inf(20),kd_sta),
     *            (inf(21),kd_xy),  (inf(22),kd_z),  (inf(23),kd_time), 
     *            (inf(24),kd_seg), (inf(25),kd_uv), (inf(26),kd_temp), 
     *            (inf(27),kd_salt),(inf(28),kd_tr), (inf(29),kd_phi), 
     *            (inf(30),kd_conv), (inf(31),kd_means),
     *            (inf(32),kd_psi), (inf(33),kd_ice),
     *            (inf(100),kd_end)

      if (nskip.eq.0) return
      if (mod(nstep, nskip) .ne. 0) goto 100

      nptz  = inf(4)*inf(6)
      npt   = inf(6)

      kd = kd_uv
      call wrda (1, iword, kd, nptz, u) 
      kd = iwrda (iword, nptz, v) 
      kd = iwrda (iword, nptz, uc) 
      kd = iwrda (iword, nptz, vc) 
      kd = iwrda (iword, nptz, h) 

      kd_temp = kd
      kd = iwrda (iword, nptz, t)

      if ( ibaro.ne.0 ) then
         kd_psi = kd
         kd = iwrda (iword, npt, psi) 
      endif
      if ( use_ice ) then
         kd_ice = kd
         kd = iwrda (iword, npt, hice) 
         kd = iwrda (iword, npt, cice) 
         kd = iwrda (iword, npt, thice) 
      endif
      if ( use_salt ) then
         kd_salt = kd
         kd   = iwrda (iword, nptz, sal) 
         kd   = iwrda (iword, nptz, dens) 
      endif
      if ( use_trac ) then
         kd_tr = kd
         kd    = iwrda (iword, nptz*ntrac, tr) 
      endif
      kd_conv = kd
      kd = iwrda(iword, nptz, convn)

      if ( save_mean ) then
         kd_means = kd
         kd = iwrda (iword, nptz, um)
         kd = iwrda (iword, nptz, vm)
         kd = iwrda (iword, nptz, tm)
         if ( use_salt ) then
            kd = iwrda (iword, nptz, salm) 
            kd = iwrda (iword, nptz, densm) 
         endif
         if ( use_trac ) kd = iwrda (iword, nptz*ntrac, trm)
      endif

      kd_end = kd

      inf(11) = nstep

      rnf(10) = ekf1 
      rnf(11) = epf1
      rnf(12) = hcf1
      rnf(13) = wcf1
      rnf(14) = vlf1
      do k = 1, inf(4)+1
         rnf(20+k) = hsave(k) 
      enddo

  100 continue
      inf(18) = nstep
      inf(13) = nscpu + ipast_scpu()
      inf(14) = nswll + ipast_swll()

      kd = 0
      call wrda (1, iword, kd, 100, inf) 
      kd = iwrda (iword, 100, rnf) 

      call flda (1)
      return
      end

      subroutine close_rstrt 
c---------------------------------
      call clda(1)
      return
      end

      subroutine dump_rstrt
c------------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      character*100 str
      character*4 mname(12)
      common /new_save/ iword, nruns, nscpu, nswll, inf(100), rnf(100)
      save mname

      data mname /'Jan.','Feb.','Mar.','Apr.','May ','Jun.',
     *            'Jul.','Aug.','Sep.','Oct.','Nov.','Dec.'/

      iword = MACHINE_WORD
      
      call opda (1, 0, fbi(1:n_in))
      kd = 0
      call rdda (1, iword, kd, 100, inf) 
      kd = irdda (iword, 100, rnf)       
      kd = irdda (1, 100, str)       

      call clda(1)

      write (6, *) 'Dump of the data file <',fbi(1:n_in),'>:'
      write (6, *) 'LABEL: ', str
      write (6, *) 'TYPE', inf(1)
      write (6, *) 'NX =', inf(2)
      write (6, *) 'NY =', inf(3)
      write (6, *) 'NZ =', inf(4)
      write (6, *) 'NT =', inf(5)
      write (6, *) 'NPACK =', inf(6)
      write (6, *) 'NSEGM =', inf(7)
      write (6, *) 'NTRACERS =', inf(8)

      call enso2date (rnf(2), id, im, iy)
      write (6, 101) 'Model Starting Date:        ', mname(im), id, iy
      call enso2date (real(rnf(2)+rnf(3)*inf(17)), id, im, iy)
      write (6, 101) 'Scheduled End of the Run:   ', mname(im), id, iy
      call enso2date (real(rnf(2)+rnf(3)*inf(18)), id, im, iy)
      write (6, 101) 'Current End of the Run:   ' , mname(im), id, iy

      call enso2res (real(rnf(3)*inf(17)), id, im, iy)
      write (6, 201) 'Scheduled Length of the Run:', iy, im, id, inf(17)
      call enso2res (real(rnf(3)*inf(18)), id, im, iy)
      write (6, 201) 'Elapsed Model Time:         ', iy, im, id, inf(18)

      write (6, *) 'Number of restarts:', inf(12)

      call enso2date (rnf(4), id, im, iy)
      write (6, 101) 'Last Re-start:              ', mname(im), id, iy
      call enso2date (real(rnf(2) + rnf(3)*inf(15)), id, im, iy)
      write (6, 101) 'Last New Run:               ', mname(im), id, iy
      call enso2date (real(rnf(2) + rnf(3)*inf(11)), id, im, iy)
      write (6, 101) 'Last Save:                  ', mname(im), id, iy

      i = inf(13)
      if (i/3600 .eq. 1) then
         write (6, 301) 'Total CPU  time:', i/3600, mod(i,3600)/60, mod(i,60) 
      else
         write (6, 302) 'Total CPU  time:', i/3600, mod(i,3600)/60, mod(i,60) 
      endif
      i = inf(14)
      if (i/3600 .eq. 1) then
         write (6, 301) 'Total WALL time:', i/3600, mod(i,3600)/60, mod(i,60) 
      else
         write (6, 302) 'Total WALL time:', i/3600, mod(i,3600)/60, mod(i,60) 
      endif

  101 format (a30, a4, i2, ',' , i5)
  201 format (a30, i5, ' Years', i3, ' months', i3, ' days. (', i7, ' steps.)') 
  301 format (a20, i5, ' hour ', i3, ' min', i3, ' sec.')
  302 format (a20, i5, ' hours', i3, ' min', i3, ' sec.') 

      return
      end

      subroutine segm_from_iox (npt, nseg, iox, iseg)
c------------------------------------------------------
      dimension iox(1), iseg(2,1)
      
      ista   = iox(1)
      inext  = ista + 1
      nseg   = 0
      icount = 0

      do i = 2, npt
         icurr = iox(i)
         icount = icount + 1

         if (inext .ne. icurr) then
            nseg = nseg + 1
            iseg(1,nseg) = ista
            iseg(2,nseg) = ista + icount - 1
            ista  = icurr
            icount = 0
         endif

         inext = icurr + 1
      enddo

      nseg = nseg + 1
      iseg(1,nseg) = ista
      iseg(2,nseg) = ista + icount 

      return
      end

      subroutine model_input(npt)
c------------------------------------------------------------
c.....read model parameters and grid from file.
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'
      include 'comm_data.h'
      include 'amlice.h'
      include 'diffiso.h'

      character*50 ubeg,vbeg,hbeg,tbeg,uout,vout,hout,tout,eout,
     +             blk,wndx,wndy,cwndx,cwndy,cloud,ccloud,wout
      common/files/ubeg,vbeg,hbeg,tbeg,uout,vout,hout,tout,eout,wout
      common/run/  nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast
      common/param0/iyear,iday,isec,delt,ncyc,mbc,nonlin,label(20),
     +              itherm,mlc,limp
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      common/winds/mtau,matau,tausc,atau,froude
      common/wnfils/wndx,wndy,cwndx,cwndy,cloud,ccloud
      common /vert/  zin(MAXNZ+1), hin(MAXNZ), t_in(MAXNZ+1), s_in(MAXNZ+1),
     *               bint(MAXNZ), cint(MAXNZ), dzin(MAXNZ+1), sigma(MAXNZ),
     *               facz(MAXNZ)
      common/strech/xs(MAXXS),alpha(MAXXS),beta(MAXXS)
      common /errors/ ioerr, nstep
      common /new_filt/  MAXFO, nbxk, nbyk, nfxk, nfpxk, nfyk


c-------------------------------------------------------------------------------
      common /pbl_param/ pbl_pnu,pbl_delta,pbl_pml,pbl_depth,pbl_betav,
     *  pbl_grad,nstep_pbl, ipbl_advec, ipbl_jsta,ipbl_jend, 
     *  pbl_south,pbl_north, pbl_wmin
c-------------------------------------------------------------------------------
      character*80       f_bar
      common /baro_files/ n_bar, f_bar
      integer iflag(12), RM12_NN 
      real    aflag(12)
      common /y12m_input/ RM12_NN, aflag, iflag
      common /baro_input/ n_def_cor, mod_scheme, mod_solver, BAR_DELTA,
     *                    BAR_DSINK, ibar_key, nbaro, rayl, nonlin_baro
      logical use_per_island, use_stan_island
      common /baro_island/
     *                alons_min(10),alons_max(10),alats_min(10),alats_max(10)
     *               ,alon1_min,alon1_max,alat1_min,alat1_max
     *               ,per_lat,n_sunk,use_per_island,use_stan_island

      logical use_hi
      common /order/ use_hi
      common/friction/b_fric
c-------------------------------------------------------------------------------

      real inp_flt, inp_days
      logical inp_def
      dimension flt(100)
      save         flt
      character*80 fbdir

      external time, ctime
      integer time
      character*24 ctime
c-------------------------------------------------------------------------------
      call inp_file(finp)
      call inp_vrnt(c_str(Variant), inp_int(c_str(Use_variant), -1))
      if (inp_int(c_str(Trace),0) .ne. 0) 
     *     call inp_trace(finp(1:mlen(finp))//'.tr\0')

      n_dir= inp_str(c_str(Output_dir),c_str(output), fbdir)
 
      n_tios= inp_str(c_str(Base_file),
     *     fbdir(1:n_dir)//'/'//finp(1:mlen(finp))//'\0',fbt)
      n_out = inp_str(c_str(Save_file), fbt(1:n_tios)//'.save\0', fbo)
      n_in  = inp_str(c_str(Restart_file), fbo(1:n_out)//'\0', fbi)

      n_wnd = inp_str(c_str(Wind_file),  c_str(wind_data), fbwnd)

      n_tem = inp_str(c_str(Temp_file) , c_str(temp_data), fbtem)
      n_sal = inp_str(c_str(Salt_file),  c_str(salt_data), fbsal)
      n_psi = inp_str(c_str(Psi_file),   c_str(psi_data), fbpsi)

      n_sst = inp_str(c_str(SST_file),   c_str(sst_data), fbsst)
      n_sss = inp_str(c_str(SSS_file),   c_str(sss_data), fbsss)

      n_cld = inp_str(c_str(Cloud_file), c_str(cld_data), fbcld)
      n_slr = inp_str(c_str(Solar_file), c_str(slr_data), fbslr)
      n_prp = inp_str(c_str(EP_file),    c_str(ep_data), fbprp)

      n_hcl = inp_str(c_str(MxlTcl_file),c_str(mltc_data), fbhcl)

      n_wsp = inp_str(c_str(Wndspd_file),c_str(wndspd_data), fwsp)
      n_uwd = inp_str(c_str(Uwnd_file),c_str(uwnd_data), fuwd)
      n_vwd = inp_str(c_str(Vwnd_file),c_str(vwnd_data), fvwd)
      n_ah  = inp_str(c_str(Airhum_file),c_str(ahum_data), fah)
      n_at  = inp_str(c_str(Airtem_file),c_str(atem_data), fat)

      n_dep = inp_str(c_str(Bath_file),  c_str(bath_data), fbdep)
      if ( inp_def(c_str(Map_file)) ) 
     *     n_map = inp_str(c_str(Map_file), c_str(map_data), fbmap)

      ipre = inp_int(c_str(Pre_proc), 0)   ! 0- normal run; 1- pre-processing

      irest = inp_int(c_str(Restart), 0)        ! 0 - start; 1 - restart

      lev_err = inp_int(c_str(Error_level), 1)

      if (irest .eq. 0) then
         open (unit = iout, file = fout)
         if (lev_err .ge. 1) then
            write (iout, *) 'Run with control file <',finp(1:mlen(finp)),'>'
            write (iout, *) 'STARTED: ', ctime(time())
         endif
      else
         open (unit = iout, file = fout, access='APPEND')
         if (lev_err .ge. 1) then
            write (iout, *) 'RE-STARTED: (code=',irest,' at:', ctime(time())
         endif
      endif

      ncyc  = inp_int(c_str(Ncycles),  4)

      delt = inp_days (c_str(Time_step), 1./24.)
      stpd = 1./delt

      mtmp = stpd - ncyc
      if (mtmp .lt. 0) mtmp = 0
      nsteps = nint(stpd * inp_days(c_str(Run_time),   365.)) + mtmp
      nskip  = nint(stpd * inp_days(c_str(Save_step),    5.))
      save_mean = inp_int(c_str(Save_mean), 1) .eq. 1
      nergy  = nint(stpd * inp_days(c_str(Energy_step), 1.))

      call inp_date (c_str(Starting_date), 1,1,2000, imon,iday,iyear)
      enso_start = date2enso (iday, imon, iyear)
      enso_scale = delt * 12./365.

      land  = 0
      iglob = inp_int(c_str(Periodic), 0)
      mbc   = inp_int(c_str(BC_type),  1)                  
      use_hi  = (inp_int(c_str(Discretization),  2) .eq. 4)

      NXP = inp_int(c_str(NX), 10)
      NYP = inp_int(c_str(NY), 10)
      NZ  = inp_int(c_str(NZ), 2)
      nsig= inp_int(c_str(Nsigma), 0)
      if (nsig.eq.1.or.nsig.eq.2.or.nsig.gt.nz.or.nsig.lt.0)then
         print*,'number of sigma layers must be 0 or between 3 and nz'
         stop
      endif

      if(max0(nxp,nyp).gt.MAXSID) call wspace('MAXSID', max0(nxp,nyp))
      if(NZ .gt. MAXNZ)           call wspace('MAXNZ', NZ)

      alat = inp_flt(c_str(South), 0.)
      blat = inp_flt(c_str(North), real(nyp-1))
      alon = inp_flt(c_str(West), 0.)
      blon = inp_flt(c_str(East), real(nxp-1))

      mgrid = inp_int(c_str(Grid_type), 1)
      
      nsx = inp_rarr(c_str(X_stretch_pnts), 0, xs,  xs)
      nsx = inp_rarr(c_str(X_alpha),        0, alpha, alpha)
      nsx = inp_rarr(c_str(X_beta),         0, beta,  beta)

      nystrch = inp_int(c_str(Y_stretch_type), 1)
      if (nystrch.eq.1) then
         nsy = inp_rarr(c_str(Y_stretch_pnts), 0, xs(nsx+1),    xs(nsx+1))
         nsy = inp_rarr(c_str(Y_alpha),        0, alpha(nsx+1), alpha(nsx+1))
         nsy = inp_rarr(c_str(Y_beta),         0, beta(nsx+1),  beta(nsx+1))
         if(nsx+nsy.gt.maxxs)         call wspace('MAXXS', nsx+nsy)
      endif

      ipole = inp_int(c_str(Pole_shift), 0)
      if (ipole .eq. 1) then
         pole_alp = inp_flt(c_str(Pole_alpha), 0.)
         pole_bet = inp_flt(c_str(Pole_beta), -90.)
         pole_gam = inp_flt(c_str(Pole_gamma), 0.)
         call comp_rotma (pole_alp, pole_bet, pole_gam)
      endif

      ibaro = inp_int(c_str(Baro_solv), 0)
      if (ibaro .ne. 0) then
         nbaro      = inp_int(c_str(Baro_step),        6)
         n_def_cor  = inp_int(c_str(Baro_defcor_step), 0)
         mod_scheme = inp_int(c_str(Baro_scheme),      9)
         mod_solver = inp_int(c_str(Baro_solver),      1)
         nonlin_baro= inp_int(c_str(Baro_nonlin),      1)

         BAR_DSINK  = inp_flt(c_str(Baro_depsink), 5.)
         BAR_DELTA  = inp_flt(c_str(Baro_delta),  50.)
         rayl       = inp_flt(c_str(Baro_rayl),   .002)
         ibar_key   = inp_int(c_str(Baro_err),    1)
         if (ibar_key .ne. 0)
     *        n_bar      = inp_str(c_str(Baro_errfile), 
     *                             finp(1:mlen(finp))//'.bar\0', f_bar)
         
         use_per_island = inp_def(c_str(Antarctica)) .or.
     *                    inp_def(c_str(Channel))
         if (use_per_island) then
            if (iglob.eq.0) then
               print*,'cannot have periodic island in non-periodic domain,' 
               print*,'  - check Periodic and Periodic_island settings'
               stop
            endif
            if (inp_def(c_str(Antarctica))) then
               per_lat = inp_flt(c_str(Antarctica_lat),-60)
            elseif (inp_def(c_str(Channel))) then
               per_lat = inp_flt(c_str(Channel_lat),(alat+blat)/2.)
            endif
         endif

         n_sunk = 0
         use_stan_island = .false.
         nis  = inp_int(c_str(Iceland),0)
         if (nis.eq.1) then     ! standard island
            use_stan_island = .true.
            if (blon.gt.360) then
               alon1_min = -25+360.
               alon1_max = -12+360.
            else
               alon1_min = -25
               alon1_max = -12
            endif
            alat1_min =  60
            alat1_max =  68
         elseif (nis.eq.2) then ! sink island
            n_sunk = n_sunk + 1
            if (blon.gt.360) then
               alons_min(n_sunk) = -25+360.
               alons_max(n_sunk) = -12+360.
            else
               alons_min(n_sunk) = -25
               alons_max(n_sunk) = -12
            endif
            alats_min(n_sunk) =  60
            alats_max(n_sunk) =  68
         endif
         nis  = inp_int(c_str(Australia),0)
         if (nis.eq.1) then     ! standard island
            if (use_stan_island) then
               print*,'can only have one standard island at present'
               stop
            endif
            use_stan_island = .true.
            alon1_min = 110
            alon1_max = 160
            alat1_min = -50
            alat1_max = -15
         elseif (nis.eq.2) then ! sink island
            n_sunk = n_sunk + 1
            alons_min(n_sunk) = 110
            alons_max(n_sunk) = 160
            alats_min(n_sunk) = -50
            alats_max(n_sunk) = -15
         endif
         nis  = inp_rarr(c_str(Other_island),5,aflag,aflag)
         if (nis.gt.0) then  
            if (nis.ne.5) then  
               print*,'For Other island, must specify 
     *              long(min,max),lat(min,max) and type'
               stop
            endif
            if (aflag(5).eq.1) then ! standard island
               if (use_stan_island) then
                  print*,'can only have one standard island at present'
                  stop
               endif
               use_stan_island = .true.
               alon1_min = aflag(1)
               alon1_max = aflag(2)
               alat1_min = aflag(3)
               alat1_max = aflag(4)
            elseif (aflag(5).eq.2) then ! sink island
               n_sunk = n_sunk + 1
               alons_min(n_sunk) = aflag(1)
               alons_max(n_sunk) = aflag(2)
               alats_min(n_sunk) = aflag(3)
               alats_max(n_sunk) = aflag(4)
            endif
         endif
c------------FROM ".y12m"--------------------------------------------
c     RM12_NN    : size of workspace in numbers of NONZ
c     iflag(11)  : number of iterations
c     iflag    : see y12m documentation
c     aflag    : see y12m documentation
c     default values:

         do i = 1, 12
            iflag(i) = 0
            aflag(i) = 0
         enddo

         RM12_NN   = inp_int(c_str(Baro_nnonz), 4)
         iflag(11) = inp_int(c_str(Baro_niter), 100)

         iflag(1)  =   1
         iflag(2)  =   3
         iflag(3)  =   1
         iflag(5)  =   2
         aflag(1)  = 2.
         aflag(2)  = 1.e-4
         aflag(3)  = 1.e6
         aflag(4)  = 1.e-12
         aflag(5)  = -1000.

         call inp_iarr (c_str(Baro_iflag), 5, iflag,  iflag)
         call inp_rarr (c_str(Baro_aflag), 5, aflag,  aflag)
      endif

      b_fric  = inp_flt(c_str(Bottom_friction),  rayl)

      nonlin= inp_int(c_str(Nonlin), 1)
      if (nonlin.ne.1) then
         print*, 'Nonlin disabled (ie, always nonlinear), please do not use'
         stop
      endif

      itemp  = inp_int(c_str(Thermo),   1)
      if (itemp.eq.0) then
         print*, 'Thermo = 0 disabled'
         stop
      endif

      isalt  = inp_int(c_str(Salinity), 0)
      isolrp = inp_int(c_str(Solar_penrad), 0)
      if (isolrp .eq. 1) solr_gamma = inp_flt(c_str(Solar_gamma), .333333)

      icl_h    = inp_int(c_str(Clim_H), 0)   ! 0-init from hin;1-Cnst;2-Vary;
      icl_psi    = inp_int(c_str(Clim_psi),0) ! 0-don't use;1-Cnst;2-Vary;

      if (icl_h .ne. 0.and.nsig.eq.0) then
         print*,'must use Nsigma > 2 if Clim_H <> 0'
         stop
      endif
      icl_htop = inp_int(c_str(Clim_htop), 0)  ! 0-Const; 1-Vary;
      
      icl_ts   = inp_int(c_str(Clim_TS),  0) ! 0-init from Tin;1-Cnst;2-Vary;
      if (icl_h.eq.2 .and. icl_ts.ne.2) 
     *     write (ioerr, *) 'Warning: check Clim_H vs. Clim_TS...'
      if (icl_ts.eq.0 .and. initt.ne.0) 
     *     write (ioerr, *) 'Warning: to initialize temp, use icl_ts <> 0'
      if (icl_ts.eq.0 .and. inits.ne.0) 
     *     write (ioerr, *) 'Warning: to initialize salt, use icl_ts <> 0'
      icl_rlx  = inp_int(c_str(Clim_relax), 0)    ! 0-no relax; 1-relax N-S;
      ksponge  = inp_int(c_str(Sponge_width), 5) 
      krelax   = inp_int(c_str(Relax_width), 5) 

      clm_time = inp_days (c_str(Clim_coef), 30.) 
      clm_time_psi = inp_days (c_str(Clim_coef_psi), 30.) 
      clm_coef = delt/clm_time
      clm_psi = nbaro*ncyc*clm_time/clm_time_psi

      clm_no   = inp_flt(c_str(Clim_nlat),  90.)  ! North relaxation latitude.
      clm_so   = inp_flt(c_str(Clim_slat), -90.)  ! South relaxation latitude.

      imix  = inp_int(c_str(Mixing),   0)
      if (imix .ne. 0) limp = inp_int(c_str(Mix_step),  3*ncyc)
      cm_mix = inp_flt(c_str(Mix_cm), 1.25)  ! "m" turbulence coefficient
      cn_mix = inp_flt(c_str(Mix_cn), 0.17)  ! "n" turbulence coefficient
      cn_mix = 1. - cn_mix
      hmin_mix = inp_flt(c_str(Mix_hmin), 10.)  ! H1 - min
      hmax_mix = inp_flt(c_str(Mix_hmax), 100.) ! H1 - max

      ric1_mix = inp_flt(c_str(Mix_ric1), .65) ! Ri for k = 1
      ric2_mix = inp_flt(c_str(Mix_ric2), .25) ! Ri for k = 2:NZ


      iuse_gam = inp_int(c_str(Mix_usegam), 0)   ! 1 - use gammas in jpmix 

      gam1_mix = inp_flt(c_str(Mix_gam1), 1.)  ! Gamma for k = 1
      gam2_mix = inp_flt(c_str(Mix_gam2), 1.)  ! Gamma for k = 2:NZ
      
      iwnd_mix = inp_int(c_str(Mix_wnd),  0)   ! 0:use tau; 1: use windspeeds

      mix_wtop = inp_int(c_str(Mix_wtop),   2)     

      if (imix .eq. 4.and.nsig .eq. 0) then
         print*, 'must set Nsigma>1 to use variable depth mixed layer'
         stop
      endif

      ntrac = inp_int(c_str(Tracers),  0)
      iice  = inp_int(c_str(Ice), 0)
      mice  = inp_int(c_str(Ice_dynamics), 0)

      use_salt = (isalt .ne. 0)
      use_trac = (ntrac .ne. 0)
      use_ice  = (iice .ne. 0)
      use_dyice = (mice .ne. 0)

      isod  = inp_int(c_str(Iso_diffusion), 0)
      use_trdiff  = (isod .ne. 0)
      isod  = inp_int(c_str(Diffiso_scl), 0)
      use_trdiff  = use_trdiff.or.(isod .ne. 0)
      isod  = inp_int(c_str(Diffiso_vel), 0)
      use_modiff  = (isod .ne. 0)
      use_diffiso  = use_trdiff.or.use_modiff

      iv_top  = inp_int(c_str(Vert_Top),  1)
      if (iv_top.ne.1.and.nsig.eq.0) then
         print*, 'must use Sigma layers for non-constant depth mixed layer'
      endif

      iv_bot  = inp_int(c_str(Vert_Bot),  99) !! 1-CNST;2-Sigm;3-W=0;4-No Motion 
      if (iv_bot.ne.99) then
         print*, 'Vert_Bot ignored, use Nsigma to determine last layer type'
      endif

      iv_bump = inp_int(c_str(Vert_Bump), 0) !! 0-Sigm;2-Sm.bmp;3-Lg.bmp;4-Exp. 
      if (iv_bump.ne.0) then
         print*, 'no interface bumps allowed, reset Vert_Bump = 0'
         stop
      endif
      
      iv_fix  = inp_int(c_str(Vert_Fix),  1) !! 0-Free Surface; 1-Fixed Depth
      if (iv_fix.ne.1) then
         print*, 'reduced gravity runs disabled, reset Vert_Fix = 1'
         stop
      endif

      iv_sys  = inp_int(c_str(Vert_Sys),  99) !! disabled
      if (iv_sys.ne.99) then
         print*, 'Vert_Sys ignored, H is filtered only in sigma layers'
      endif

      mbot_bc = inp_int(c_str(BC_bot_temp), 0) !! 0-constant temp; 1 - d/dz=0
      if (mbot_bc.ne.1) then
         print*, 'do you REALLY want constant bottom temp with bathymetry?'
         print*, 'reconsider using BC_bot_temp = 1'
         stop
      endif

      dshapu = inp_flt(c_str(Shap_vel_damp), 1.0)
      dshaph = inp_flt(c_str(Shap_scl_damp), 1.0)

      nordu  = inp_int(c_str(Shap_vel_order), 4)
      mshapu = inp_int(c_str(Shap_vel_type),  3)
      nshapu = inp_int(c_str(Shap_vel_step),  3*ncyc)

      nordh  = inp_int(c_str(Shap_scl_order), 4)
      mshaph = inp_int(c_str(Shap_scl_type),  1)
      nshaph = inp_int(c_str(Shap_scl_step),  3*ncyc)

      nord  = max(nordu,nordh)
      MAXFO = nord

      mtau  = inp_int(c_str(Wind_forc),  0)
      if (mtau .eq. 5) itau_cos = inp_int(c_str(Wind_cos), 0)
      call inp_rarr (c_str(Wind_tauxy), 2, flt, flt)
      tausc = flt(1)
      atau  = flt(2)

      initt  = inp_int(c_str(Temp_init), 0)
      temp_coef  = inp_flt(c_str(Temp_coef), 0.)
      if (initt.ne.0.and.initt.ne.3) then
         print*,'must use Temp_init = 0 or 3'
         stop
      endif
      inits  = inp_int(c_str(Salt_init), 0)
      if (inits.ne.0.and.inits.ne.3) then
         print*,'must use Salt_init = 0 or 3'
         stop
      endif

      froude = inp_flt(c_str(Temp_froude), 0.01)

      initq  = inp_int(c_str(Heat_forc), 0)
      initep = inp_int(c_str(EP_forc), 0)

      igas  = inp_int(c_str(Gas_exchange), 0)
      use_wnsp  = (igas .ne. 0)
      if (use_ice.or.initq.eq.8) use_wnsp = .true.

      if (use_ice.and.initq.ne.8) then
         print*,'Using AML-ICE, so I am ignoring your Heat_forc parameter'
      endif

      if (initq.ne.8 .and. iice.ne.1)iwnd_mix = 0 ! valid only if PBL is "ON"

      qcon     = inp_flt (c_str(Rho_CP), 4.12e6)
      rlx_time = 86400.*inp_days (c_str(Rlx_time), 30.) 

      if (initq .ge. 8 .or. use_ice) then
         nstep_pbl  = nint(stpd * inp_days(c_str(PBL_step), 5.))
         ipbl_advec = inp_int(c_str(PBL_advec), 1)
         pbl_wmin   = inp_flt(c_str(PBL_wmin),  4.)
         pbl_pnu    = inp_flt(c_str(PBL_pnu),   0.4e+7)
         pbl_delta  = inp_flt(c_str(PBL_delta), 0.25 )
         pbl_pml    = inp_flt(c_str(PBL_pml),   6000.)
         pbl_depth  = inp_flt(c_str(PBL_depth), 600. )
         pbl_betav  = inp_flt(c_str(PBL_betav), 0.17 )
         pbl_grad   = inp_flt(c_str(PBL_grad),    -2.)
         pbl_south  = inp_flt(c_str(PBL_south), -200.)
         pbl_north  = inp_flt(c_str(PBL_north),  200.)
      endif
      if (use_ice) then
c             default values are given amlice.h
         albedoocean = inp_flt(c_str(ICE_albedoocean), albedooceandef)
         albedoice   = inp_flt(c_str(ICE_albedoice  ), albedoicedef) 
         albedof     = inp_flt(c_str(ICE_albedof    ), albedofdef) 
         tfreeze     = inp_flt(c_str(ICE_tfreeze    ), tfreezedef) 
         cicemax     = inp_flt(c_str(ICE_cicemax    ), cicemaxdef)
         hsnow       = inp_flt(c_str(ICE_hsnow      ), hsnowdef)
         sice        = inp_flt(c_str(ICE_sice       ), sicedef)
         itermax     = inp_int(c_str(ICE_itermax    ), itermaxdef)
         ssticemax   = inp_flt(c_str(ICE_ssticemax  ), ssticemaxdef)
         hicemin     = inp_flt(c_str(ICE_hicemin    ), hicemindef)
         tksnow      = inp_flt(c_str(ICE_tksnow     ), tksnowdef)
         tkice       = inp_flt(c_str(ICE_tkice      ), tkicedef)
         tkocean     = inp_flt(c_str(ICE_tkocean    ), tkoceandef)
         hq          = inp_flt(c_str(ICE_hq         ), hqdef)
         hf          = inp_flt(c_str(ICE_hf         ), hfdef)
         if (use_dyice) then
            dyice_p     = inp_flt(c_str(ICE_dyice_p    ), dyice_pdef)
            dyice_e     = inp_flt(c_str(ICE_dyice_e    ), dyice_edef)
            dyice_c     = inp_flt(c_str(ICE_dyice_c    ), dyice_cdef)
            dyice_emin  = inp_flt(c_str(ICE_dyice_emin ), dyice_emindef)
            dyice_alpai = inp_flt(c_str(ICE_dyice_alpai), dyice_alpaidef)
            dyice_alpiw = inp_flt(c_str(ICE_dyice_alpiw), dyice_alpiwdef)
            dyice_cai   = inp_flt(c_str(ICE_dyice_cai  ), dyice_caidef)
            dyice_ciw   = inp_flt(c_str(ICE_dyice_ciw  ), dyice_ciwdef)
         endif
      endif
      if (use_diffiso) then
c             default values are given diffiso.h
         diffiso_alpha = inp_flt(c_str(Diffiso_alpha), diffiso_alphadef) 
         diffiso_eps   = inp_flt(c_str(Diffiso_eps), diffiso_epsdef) 
         diffiso_coef  = inp_flt(c_str(Diffiso_coef), diffiso_coefdef) 
         diff_coef_tr  = diffiso_coef
         diffiso_coef  = inp_flt(c_str(Diffiso_coef_mo), diff_coef_tr) 
         diff_coef_mo  = diffiso_coef
         print*,'diff_coef_tr,diff_coef_mo',diff_coef_tr,diff_coef_mo
         diffiso_slmax = inp_flt(c_str(Diffiso_slmax), diffiso_slmaxdef) 
         slred=inp_flt(c_str(Diffiso_slred),diffiso_slreddef) 
         sigzmin=inp_flt(c_str(Diffiso_sigzmin),sigzmindef) 
         if (sigzmin.ge.0) then
            print*,'Diffiso_sigzmin should be negative'
            stop
         endif
         diffiso_cadv=inp_flt(c_str(Diffiso_cadv),diff_coef_tr) 
         use_diff_cadv = diffiso_alpha.ne.0 .and. diffiso_cadv.ne.0
         if (use_diff_cadv) then
            facz_cnst = inp_flt(c_str(Diffiso_facz_cnst), facz_cnstdef) 
            do k = 1, nz
               facz(k) = facz_cnst
            enddo
            call inp_rarr(c_str(Diffiso_facz),nz,facz,facz) 
            psi_rel=inp_flt(c_str(Diffiso_psi_relax),psi_relaxdef) 
            print*,'using Gent-McWilliams mixing ...'
         endif
      endif

      cnst_upwind = inp_flt(c_str(Upwind_cnst),cnst_upwinddef) 
      cnst_upwind_ts = inp_flt(c_str(Upwind_cnst_ts),cnst_upwind) 
      cnst_upwind_tr = inp_flt(c_str(Upwind_cnst_tr),cnst_upwind) 
      if (cnst_upwind.lt.1.) then
         print*,'do not use Upwind_cnst less than one'
         stop
      endif
      cupi_ts = 1./(cnst_upwind_ts + 1.)
      cupi_tr = 1./(cnst_upwind_tr + 1.)

      initb = inp_int(c_str(Bathymetry), 0)
      if (initb.ge.3) then
         i_ridge_min = inp_int(c_str(Ridge_min),0)
         i_ridge_max = inp_int(c_str(Ridge_max),nxp+1)
      endif
      
      initbt = inp_int(c_str(Bath_type), 0)
      dep_min = inp_flt(c_str(Bath_min), 100)

      nzz = inp_rarr(c_str(Z_profile), nz, zin, zin)
      nzh = inp_rarr(c_str(H_profile), nz, hin, hin)

      if (nz .gt. nzz .and. nz .gt. nzh) then
         call perror1('Z_profile or H_profile: not enough terms...',-1)
         stop
      endif

      zin(1) = hin(1)/2.
      z_bot  = hin(1)
      do k = 2, nz
         zin(k) = - zin(k-1) + 2.*z_bot
         z_bot = z_bot + hin(k)
      enddo
      zin(nz+1) = z_bot
      dzin(1) = zin(1)
      do j = 2, nz
         dzin(j) = (zin(j)-zin(j-1))/2.
      enddo
      dzin(nz+1) = zin(nz+1)-zin(nz)

c  Z_profile specification overrides H_profile 

      zdum = inp_flt(c_str(Z_bot), 0)

      if (zdum.eq.0.and.z_bot.eq.0) then
         print*,'must specifiy Z_bot as well as Z_profile'
         stop
      elseif (zdum.gt.0) then
c        reread  Z_profile
         ndum =  inp_rarr(c_str(Z_profile), nz, zin, zin)
         
         zin(1) = zin(2)/3.     ! enforce this condition
         zin(nz+1) = zdum
         
         dzin(1) = zin(1)
         do j = 2, nz
            dzin(j) = (zin(j)-zin(j-1))/2.
            if (dzin(j).lt.0.)then
               print*,'negative layer depths, check Z_profile'
               stop
            endif
         enddo
         dzin(nz+1) = zin(nz+1)-zin(nz)
         if (dzin(nz+1).lt.0.)then
            print*,'negative depth of last layer, check Z_bot'
            stop
         endif
         
         hin(1) = 2.*dzin(1)
         do j = 1, nz
            hin(j) = dzin(j) + dzin(j+1)
         enddo
      endif

      do j = 1, nz
         if (hin(j).le.0) then
            print*,'a layer depth is negative, check Z_profile or H_profile'
            stop
         endif
      enddo

      z_begin = zin(nsig)

      sigma(1) = -1./3.
      sigma(2) = sigma(1)
      do j = 3, nsig
         sigma(j) = dzin(j)/(z_begin-3.*dzin(1))
      enddo
      do j = nsig + 1, nz
         sigma(j) = 0.
      enddo

      trans_coef = (zin(1)+zin(2))/2./rlx_time

      i = inp_rarr(c_str(T_profile), nz, t_in, t_in)
      if  (i .lt. nz) then
         call perror1('T_profile: not enough terms...',-1)
      elseif (i .eq. nz) then
         t_in(nz+1) = inp_flt(c_str(Temp_bot), 0.)
      endif
      TATM = inp_flt(c_str(Temp_atm), 30.)

      i = inp_rarr(c_str(S_profile), nz, s_in, s_in)
      if  (i .lt. nz) then
         call perror1('S_profile: not enough terms...',-1)
      elseif (i .eq. nz) then
         s_in(nz+1) = inp_flt(c_str(Salt_bot), 36.)
      endif
      SATM = inp_flt(c_str(Salt_atm), 35.4)

      TEMP_BOT = t_in(nz+1)
      SALT_BOT = s_in(nz+1)
      POTND_BOT = inp_flt(c_str(Dens_bot), pdens_pnt (TEMP_BOT, SALT_BOT))

c.....Bi & Ci are now *real* "Nu" & "Ka" (not scaled by depth):      
      bi = inp_flt (c_str(Bint), 1.e-3)
      ci = inp_flt (c_str(Cint), 1.e-4)
      do i = 1, nz
         bint(i) = bi
         cint(i) = ci
      enddo

      call inp_str(c_str(Grid_label),'Data: '//finp(1:mlen(finp))//'\0',label)
      call mem_alloc (p_mask, NXP*NYP*NZ, 1, 'mask')

      if (n_map  .ne. 0) call inp_file(fbmap(1:n_map)//'\0')
      call read_mask ('Grid_mask', nxp, nyp, nxyc, mask)

      call mem_alloc (p_iox, nxyc, 1, 'iox')

      npt  = nxyc
      npt1 = 1
      npt2 = 1 + npt 
      npt3 = 1 + 2*npt 
      npt4 = 1 + 3*npt 

      first_step = .true.

      if (lev_err .ge. 1 .and. irest .eq. 0) then
         write (iout, *) 'NX =', nxp
         write (iout, *) 'NY =', nyp
         write (iout, *) 'NZ =', nz
         write (iout, *) 'NPACK =', nxyc
         write (iout, *) 'NTRACERS =', ntrac
         if (ibaro .eq. 0) then
            write (iout, *) 'BARO OFF'
         else
            write (iout, *) 'BARO ON'
         endif
         call flush(iout)
      endif

      call hfx_pert_init

      return
      end

      subroutine read_mask (tag, nx, ny, npack, mask)
c-----------------------------------------------------
      character*(*) tag
      dimension mask(nx, 1)
      character*1  ch, buff(1000)
      character*465 number
      logical inp_def

      equivalence (ch, buff(1)), (number, buff(2))

      if ( inp_def(tag//'\0') ) then
         ix = 1
         jy = ny
         ic0 = ichar('0')
         do while ( inp_wnxt(buff) .gt. 0)
            if     (ch.eq.'0' .or. ch.eq.'1' .or. ch.eq.'2') then
               do i = 1, nx
                  mask(i,jy) = ichar(buff(i)) - ic0
               enddo
               jy = jy - 1
            elseif (ch.eq.'w'.or.ch.eq.'z'.or.ch.eq.'x'.or.ch.eq.'s'
     *               .or.ch.eq.'b'.or.ch.eq.'t') then
               read (number, *) kx 
               ix = ix + kx
               if (ix - 1 .gt. NX) goto 200
               if (ch.eq.'w') ich = 1 
               if (ch.eq.'x') ich = 2 
               if (ch.eq.'s') ich = 3 
               if (ch.eq.'t') ich = 4 
               if (ch.eq.'b') ich = 5 
               if (ch.eq.'z') ich = 0 
               do i = ix-kx, ix-1
                  mask(i,jy) = ich
               enddo
               if (ix-1 .eq. NX) then
                  ix = 1
                  jy = jy - 1
               endif
            elseif (ch .eq. 'r') then
               read (number, *) ky
               jy = jy - ky + 2
               if (jy .lt. 1) goto 200
               do j = jy+ky-2, jy, -1
                  do i = 1, nx
                     mask(i,j) = mask(i,j+1)
                  enddo
               enddo
               jy = jy - 1
            else
               goto 200
            endif
            
            if (jy .eq. 0) goto 100
         enddo


  100    npack = 0

         do j = 1, ny
            do i = 1, nx
               if (mask(i,j) .ne. 0) npack = npack + 1
            enddo
         enddo

      else
         npack = nx*ny
         do j = 1, ny
            do i = 1, nx
               mask(i,j) = 1
            enddo
         enddo
      endif

      return

  200 write (6, *) '!!!read_mask: wrong mask data, i,j:', ix,jy
      stop
      end

     
dyn_main.f/     849548185   1572  1572  100666  17634     `
************************************************************************
      program !MCPG
      implicit real(a-h,o-z),integer(i-n)
c************************************************************************
      include 'comm_para.h'
      include 'comm_new.h'
      include 'comm_data.h'
      include 'diffiso.h'
      include 'comm_tracer.h'
 
      dimension 
     *     en(MPTEN*(MAXNZ+1)),
     *     lxxk(MXBDY*MAXNZ),lyyk(MXBDY*MAXNZ),
     *     lxyk(MAXNB*MAXNZ),lyxk(MAXNB*MAXNZ),lsponge(MAXSP),
     *     lrelax(MAXSP),
     *     snxk(MAXNB*MAXNZ),snyk(MAXNB*MAXNZ),lok(4*MAXSID*MAXNZ),
     *     lpbcwk(MAXSID*MAXNZ),lpbcek(MAXSID*MAXNZ),
     *     ifxk(9*MAXSID*MAXNZ), ifpxk(5*MAXSID*MAXNZ), ifyk(9*MAXSID*MAXNZ)
     *     ,basin(MAXNZ)

      logical NEWRUN, non_stable
 
      common /param0/iyear,iday,isec,delt,ncyc,mbc,nonlin,label(20),
     *               itherm,mlc,limp
      common /run/   nstart,nlaststart,nskip,nsteps,nergy,nskipo,nlast

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      common /winds/ mtau,matau,tausc,atau,froude
      common /vert/  zin(MAXNZ+1), hin(MAXNZ), t_in(MAXNZ+1), s_in(MAXNZ+1),
     *               bint(MAXNZ), cint(MAXNZ), dzin(MAXNZ+1), sigma(MAXNZ),
     *               facz(MAXNZ)
      common /strech/ xs(MAXXS), alpha(MAXXS), beta(MAXXS)
      common /errors/ ioerr, nstep
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      common /baro_input/ n_def_cor, mod_scheme, mod_solver, BAR_DELTA,
     *                    BAR_DSINK, ibar_key, nbaro, rayl, nonlin_baro
      common /main/npt

 
      data ioin,iout,ioerr /1,2,2/, k15flag /0/
 
      npten = MPTEN
c...............getting input & output filenames from the command line
      call inout (ioin)
 
c...............input model parameters.
      call model_input(npt)
      call model_memory (nxp, nyp, nz, npt) 
      call make_iox (nxp, nyp, mask, iox, nlok, lok, nsponge, lsponge,
     *               nrelax, lrelax, iglob)
      if (nrelax.gt.MAXSP) then
         print*,'increase MAXSP'
         stop
      endif
      call scaset (iox,xm,ym,xp,yp,f,emx,emy,emxy,emx2,emy2,tp)
      call depth_init (npt, zin)

      call new_topo (nxp, nyp, nz, npt, zin, dzin, hin, nsig, sigma, dept, 
     *               h, nptk, nzi)

      call bndrys(npt,iox,tp,isxk,isyk,mask,h,nzi,
     *            isk,iyk,lxxk,lyyk,lxyk,lyxk,snxk,snyk,lok,
     *            lpbcwk,lpbcek,ifxk,ifpxk,ifyk,dept)

      call baro_dept(npt,nz,nzi,nzi_b,h,lxxk,lyyk,mbc,dept,tp,tp(npt2))

      call data_init (npt,nptk,nz,isk,u,v,uc,vc,fu,fv,ft,fsal,bdiv,ubar,vbar,use_salt)

c..............compute some geometry stuff
      call aarea  (npt,nz,lxxk,lyxk,emx,emy,area,basin,isk)

      if (irest .eq. 0) then
         NEWRUN = .true. 
         call init_rstrt (nxp, nyp, nz, npt, zin, tp)
      else
         NEWRUN = irest .eq. 3
         if (irest.eq.1 .or. irest.eq.2) CALL TIOS_CNTRL (3, 1)
         if (ibaro .ne. 0) ibaro = 1
         call read_rstrt (nxp, nyp, nz, npt)
      endif
c..............initialize Temperature/Salinity Climatology (for sponges):

      call clim_init(npt,nstart,hin,sigma,dzin,h,
     *                 hclim,tclim,sclim,dclim,pclim,tp,nsponge,lsponge)

      if (irest .eq. 0) then
         call h_init (npt, nz, nzi, nstart, h, hclim)
         call temp_init (npt,nz,nzi,nstart,t_in,t,tclim)
         if (use_salt) call salt_init (npt,nz,nzi,nstart,s_in,sal,sclim)
      endif

c..............initialize Heat/EP forcing:
      if (use_ice) then
         call amlice_data_init(nstart,npt,nxp,nyp, 
     *                  t, sst, cld, solr, sal, sss, prcp, nrelax, lrelax)
         
      else
         call hflx_init (nstart,npt,nxp,nyp,t,sst,cld,solr,nrelax,lrelax)
         if (use_salt) call ep_init (nstart, npt, sal, sss, prcp)
      endif

      if (use_salt) call dens_init (npt, nz, nzi, t, sal, dens, h) 

      if (use_diffiso) then
         call diff_init(npt,iglob,mgrid)
         if (diffiso_alpha.gt.0) then
            call potn_dens (npt, nzi, t, sal, pdens) 
         endif
      endif
      if (use_diff_cadv) then
         nptz = npt*nz
         call mem_alloc (p_ucs, nptz, 2, 'ucs')         
         call mem_alloc (p_vcs, nptz, 2, 'vcs')         
         call mem_alloc (p_ws, nptz, 2, 'ws')         
         call mem_alloc (p_fhds, nptz, 2, 'fhds')         
      else
         p_ucs = p_uc
         p_vcs = p_vc
         p_ws  = p_w
         p_fhds= p_fhd
      endif
      
c..............initialize Wind forcing:
      call tau_init (nstart, npt, dtx, dty) 

      dnt     = delt * real(ncyc) * D2SEC
      dtmix   = delt * real(limp) * D2SEC
      DLT_MIX = 2.0 * dtmix 

c..............initialize TIOS io-system
      if (use_trac) then
         call tracer_input(npt,nz,ntimes,nstart,nstep)
         call tracer_init(npt,nz,nstart,nxp,nyp,iox,tr,h,xm,ym,tp)
      endif
         
      call init_data_out (ftios, fbt, nxp, nyp, npt, xm, ym, en)
c
      istep     = 0
      iday_new  = int(nstart*delt)
      iday_curr = iday_new

      if (ibaro .ne. 0) then
         eps1 = 1./dnt
         eps2 = eps1
         if (ibaro .eq. 2) eps1 = 0.
         call baro_sum (npt, nz, nzi_b, uc, vc, ubar, vbar)
         call baro_scale (npt, ubar, vbar, dept)
         mem0 = mem_get()
         call baro_init (iglob,eps1,nxp,nyp,nxyc,iox,nbxk,lxxk,
     *        nbyk,lyxk,alon,blon,alat,blat,xm,ym,dept,dep_max)
         write(iout, *)'Barotropic solver memory = ',mem_get()-mem0,' bytes.'
         if (ibaro .eq. 2) then
            call baro_tau (npt, uforc, vforc, taux, tauy)
            call baro_rhs (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk,
     *      isyk,isk,mbc,lpbcwk,lpbcek,uforc,vforc,tp,tp(npt2),dept)  
            call baro_solv (nxp,nyp,npt,iox,tp,uforc,vforc,psi)    
            call psi_relax (npt,psi,pclim,tp,nbxk,lxxk,nbyk,lyyk)
            call curl_of_psi (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk,
     *        isyk,isk,mbc,lpbcwk,lpbcek,psi,tp(npt1),tp(npt2),tp(npt3),dept)
            call baro_updat(npt,nz,nzi_b,h,uc,vc,
     *                      tp(npt1),tp(npt2),uforc,vforc,ubar,vbar)
            call decap (npt, nz, nzi, u,v,uc,vc,h)
         endif
         call baro_div (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,
     *        snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,ubar,vbar,bdiv,tp,dept)
c         if (eps1.ne.eps2) call baro_rinit (eps2) 
         call baro_rinit (eps2) 
      endif
      write(iout, *)'Total allocated memory   = ',mem_get(),' bytes.'

      call bcset (mbc,lxxk,lyyk,npt,u,v,nzi,nzi_b)
      call baro_shap(nstep,npt,nz,nzi,nzi_b,dept,h,uc,vc,ubar,vbar,u,v,lxxk,lyyk)

c...............compute w from the initial fields.
      call ddiv(npt,nzi_b,uc,vc,emx,emy,emxy,w,fhd,lxxk,lyyk,lxyk,lyxk,snxk,snyk,
     *          isyk,isk,tp,mbc,lpbcwk,lpbcek,h,bdiv)
      call wtop (npt, w, fhd, fh, h, ncyc, istep, dnt)
      call dwcal (npt,nz,nsig,nzi,w,fhd,sigma)

c.........................................................................
c.....MAIN LOOP .......use an n-cycle Lorentz scheme for the timestep loop.
      call cpulog (fcpu, 0, iday_curr)

      DO NSTEP = NSTART, NLAST

         tenso = enso_start + enso_scale * nstep
         if (use_trac) then
            rjuljar = tenso/12.+1960.
            juljar  = int(rjuljar)
            call force_tracer(npt,nz,ntrac,nstep,nxp,nyp,iv_bot,
     &              rjuljar,juljar,dnt,
     &              nzi,tr,ftr,t,h,
     &              sal,ym,iox,tp)
         endif

         if (diffiso_alpha.gt.0) then
            call slope(npt,pdens,nzi,h,
     *        lxxk,lyyk,snxk,snyk,isyk,isk,lok,tp,lpbcwk,lpbcek)
            if (use_diff_cadv) then
               call adv_iso(pdens,ucs,vcs,uc,vc,h,npt,nz,nzi,facz)
               call bcset (mbc,lxxk,lyyk,npt,ucs,vcs,nzi,nzi_b)
               call ddivs(npt,ucs,vcs,emx,emy,emxy,ws,fhds,lxxk,lyyk,
     *              lxyk,lyxk,snxk,snyk,isyk,isk,tp,mbc,lpbcwk,lpbcek)
               call wtop (npt, ws, fhds, fh, h, ncyc, istep, dnt)
               call dwcal (npt,nz,nsig,nzi,ws,fhds,sigma)
            endif
         endif

         if     (mtau .eq. 1) then
            call tau_lin(nstep,npt, ixd,im2d,blcf, taux,tauy,dtx,dty,tp)
         endif

         call clim_updt(npt,nz,nstep,hin,sigma,dzin,hclim,tclim,sclim,dclim)
         if (use_ice) then
            call amlice_flux(nstep, delt, npt, nxp, nyp,
     *                    sst, cld, solr, wnd, sal, sss, prcp, qb)
c            if (use_dyice) 
c     *         call iceforc(fxice,fyice)
         else
            call qforc(nstep, npt, nxp,nyp, sst,cld,solr, wnd, qb)
            if (use_salt) call epforc(nstep, npt, sal, sss, prcp, qb)
         endif

         if (ihfprt .gt. 0) then
            call hflx_pert(npt,nz,nxp,nyp,nstep,ym)
         endif
         
         call vertu (npt,nz,nsig,nzi,nzi_b,bint,taux,tauy,u,v,w,h,fu,fv,fh,
     *               vertx,verty,zfu,zfv)

         call dhoriz (npt,u,v,uc,vc,f,fu,fv,fhd,emx,emy,emxy,tp,mbc,zfu,zfv,
     *        lxxk,lyyk,lxyk,lyxk,snxk,snyk,isyk,isk,lpbcwk,lpbcek,nzi_b,
     *        corx,cory,xnl,ynl,fh,nonlin_baro)

         call btpgf (npt, nzi_b, h, t,dens,fu,fv,emx,emy,lxxk,lyyk,lxyk,lyxk,
     *        snxk,snyk,isyk,isk,lok,tp,u,v,lpbcwk,lpbcek,zfu,zfv,pgfx,pgfy)
         
         if (use_salt) then
            call vertts (npt,nz,nzi,cint,q,qr,ep,ws,h,t,ft,sal,fsal)
         else
            call vertt (npt,nz,nzi,cint,q,qr,ws,h,t,ft)
         endif
   
         if (use_trac) call verttr (npt,nz,nzi,cint,ws,h,tr,ftr)
   
         call thoriz (npt,ucs,vcs,t,ft,fhds,emx,emy,lxxk,lyyk,lxyk,lyxk,
     *        snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek)
         call capt (npt,nz,nzi,t,h)
         
         if (use_salt) then
            call thoriz (npt,ucs,vcs,sal,fsal,fhds,emx,emy,lxxk,lyyk,lxyk,
     *           lyxk,snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek)
            call capt(npt,nz,nzi,sal,h)
         endif
         
         do i = 1, ntrac
            it = npt*nz*(i-1)+1
            call thoriz (npt,ucs,vcs,tr(it),ftr(it),fhds,emx,emy,lxxk,lyyk,
     *           lxyk,lyxk,snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek)
            call capt (npt,nz,nzi,tr(it),h)
         enddo

c            if (use_dyice) 
c     *         call ice_adv()
         
c  add momentum diffusion, if desired
         if (use_modiff) then
            call diff_iso(diff_coef_mo,npt,nzi,h,uc,fu,
     *       lxxk,lyyk,snxk,snyk,isyk,isk,tp,lpbcwk,lpbcek)
            call diff_iso(diff_coef_mo,npt,nzi,h,vc,fv,
     *       lxxk,lyyk,snxk,snyk,isyk,isk,tp,lpbcwk,lpbcek)
         endif

c  add tracer diffusion, if desired
         if (use_trdiff) then
            call diff_iso(diff_coef_tr,npt,nzi,h,t,ft,
     *       lxxk,lyyk,snxk,snyk,isyk,isk,tp,lpbcwk,lpbcek)
            call diff_iso(diff_coef_tr,npt,nzi,h,sal,fsal,
     *       lxxk,lyyk,snxk,snyk,isyk,isk,tp,lpbcwk,lpbcek)
            do i = 1, ntrac
               it = npt*nz*(i-1)+1
               call diff_iso(diff_coef_tr,npt,nzi,h,tr(it),ftr(it),
     *              lxxk,lyyk,snxk,snyk,isyk,isk,tp,lpbcwk,lpbcek)
            enddo
         endif
c            if (use_dyice) 
c     *         call ice_diff()

         binv  = dnt/(ncyc-istep)
         istep = mod(istep+1,ncyc)
         abinv = -(istep/dnt)*binv
         
         call baro_sum(npt,nz, nzi_b, fu,fv,u,v)
         call baro_scale (npt, u, v, dept) 
         call fixed_dep(npt,nzi_b,h,fu,fv,u,v,rhsx,rhsy,crhsx,crhsy)  

         call vel_updat (npt,nz,nzi_b,binv,abinv,uc,vc,fu,fv)

         if  (ibaro .ne. 0) then
            call baro_comp(npt,dnt,abinv,binv,nbaro,uforc,vforc,u,v,zfu,zfv,dept)
            
            if (mod(nstep, nbaro*ncyc) .eq. 0) then
               call baro_rhs(npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,snxk,snyk,
     *              isyk,isk,mbc,lpbcwk,lpbcek,uforc,vforc,u,tp,dept)  
               call baro_solv (nxp,nyp,npt,iox,u,uforc,vforc,psi)    
               call psi_updt(npt,nstep,pclim)
               call psi_relax (npt,psi,pclim,tp,nbxk,lxxk,nbyk,lyyk)
               call curl_of_psi (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,
     *              snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,psi,u,v,tp,dept)
               call baro_updat(npt,nz,nzi_b,h,uc,vc,u,v,uforc,vforc,ubar,vbar)
               call baro_div (npt,emx,emy,emxy,lxxk,lyyk,lxyk,lyxk,
     *           snxk,snyk,isyk,isk,mbc,lpbcwk,lpbcek,ubar,vbar,bdiv,tp,dept)
            endif
         endif
         call bcset (mbc,lxxk,lyyk,npt,uc,vc,nzi,nzi_b)
         call shap_vec (nstep,npt,nz,uc,vc,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
         call decap (npt, nz, nzi, u,v,uc,vc,h)

         if (nsig.gt.0) then
            call h_updat (npt,nsig, binv,abinv,h,fh)
            call hbcset (npt, nz, nsig, lok, h, hclim)
            call shap_scl(nstep,npt,nsig,h,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
         endif

         call tupdat(npt,nz,nzi,binv,abinv,t,ft)
         call tbcset(npt,nz,lok,t_in,h,t,tclim) !reset temp at open boundaries
         call shap_scl(nstep,npt,nz,t,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
         call tdecap (npt, nz, nzi, t, h)
         if (.not.use_ice) call t_limit (npt, nzi, t)

         if (use_salt) then
            call tupdat(npt,nz,nzi,binv,abinv,sal,fsal)
            call tbcset(npt,nz,lok,s_in,h,sal,sclim)
            call shap_scl(nstep,npt,nz,sal,lxxk,lyxk,isyk,isk,ifxk,ifpxk,ifyk,tp)
            call tdecap (npt, nz, nzi, sal, h)
         endif

         if (use_trac) then
            do i = 1, ntrac
               it = npt*nz*(i-1)+1
               call tupdat(npt,nz,nzi,binv,abinv,tr(it),ftr(it))
               call shap_scl(nstep,npt,nz,tr(it),lxxk,lyxk,isyk,isk,
     &                  ifxk,ifpxk,ifyk,tp)
               call tdecap (npt,nz, nzi, tr(it), h)
            enddo
         endif

c            if (use_dyice) 
c     *         call ice_updat()
         
         if (imix.ne.0 .and. mod(nstep, limp).eq.0) then
            if     (imix .eq. 1) then !! Convective Adjustment
               call dconv (npt,nz,nzi,u,v,uc,vc,h,t,sal,pdens,tr,convn)
            elseif (imix .eq. 2) then !! Ri Number Mixing
               call decap (npt, nz, nzi, u,v,uc,vc,h)
               call drich_mix (npt, nz, nzi, h, u,v,uc,vc,t,sal,pdens)
            elseif (imix .eq. 3) then !! Combination of (1) & (2)
               call decap (npt, nz, nzi, u,v,uc,vc,h)
               call drich_mix (npt, nz, nzi, h, u,v,uc,vc,t,sal,pdens)
               call dconv (npt,nz,nzi,u,v,uc,vc,h,t,sal,pdens,tr,convn)
            elseif (imix .eq. 4) then !! Dake Chen's Scheme
               call decap (npt, nz, nzi, u,v,uc,vc,h)
               call comp_bncy(npt,nzi,pdens,tp)
               call cvmix(npt,nzi,h,t,sal,tp,u,v)
               call jpmix(npt,nz,nzi,h,t,sal,tp,u,v)
               call ktmix(npt,nsig,dtmix,h,t,sal,tp,u,v,q,qr,ep,taux,tauy,sigma,uc)
               call capfrm(npt,nz,nzi,u,v,uc,vc,h)
            elseif (imix .eq. 5) then !! Dake Chen's Conv. Adjustment only
               call decap (npt, nz, nzi, u,v,uc,vc,h)
               call comp_bncy(npt,nzi,pdens,tp)
               call cvmix(npt,nzi,h,t,sal,tp,u,v)
               call capfrm(npt,nz,nzi,u,v,uc,vc,h)
            endif
         endif

         call clim_relax (npt,nz,h,t,sal,hclim,tclim,sclim)

         if (use_salt) then
            call situ_dens (npt, nz, nzi, t, sal, dens, h)
            call potn_dens (npt, nzi, t, sal, pdens) 
         endif

         call bcset (mbc,lxxk,lyyk,npt,u,v,nzi,nzi_b)
         call baro_shap(nstep,npt,nz,nzi,nzi_b,dept,h,uc,vc,ubar,vbar,u,v,lxxk,lyyk)

         call ddiv(npt,nzi_b,uc,vc,emx,emy,emxy,w,fhd,lxxk,lyyk,lxyk,lyxk,
     *        snxk,snyk,isyk,isk,tp,mbc,lpbcwk,lpbcek,h,bdiv)
         call wtop (npt, w, fhd, fh, h, ncyc, istep, dnt)
         call dwcal (npt,nz,nsig,nzi,w,fhd,sigma)

         if (NEWRUN .or. (nergy.ne.0 .and. mod(nstep, nergy).eq.0)) then
            call knergy(npt,nz,nptk,isk,area,basin,h,u,v,en)
            call pnergy (NEWRUN,npt,nptk,nz,isk,h,area,t,dens,w,basin,en,tp)
         endif

         if (non_stable(iout, npt, nxp, nz, iox, t, u, v)) then
            call cpulog (fcpu, nstep, iday_curr)
            write (iout, *) 'Stable:ERROR, step', nstep, ' temp or velocity is bizarre' 
            print*, 'Stable:ERROR, step', nstep, ' temp or velocity is bizarre' 
            goto 333
         else
            if ( mod(nstep,ncyc) .eq. 0 ) then
               
               iday_new = int(nstep*delt)
               call add_mean
               
               call keep_rstrt(nstep, nskip)
               
               call data_out (tenso, nxp, nyp, npt, en) 

               if (NEWRUN .or. (iday_new .ne. iday_curr)) then
                  iday_curr = iday_new
                  call cpulog (fcpu, nstep, iday_curr)
                  if (NEWRUN) NEWRUN = .false.
               endif
            endif
         endif
         
         call flush(iout)
         if ( first_step ) first_step = .false.

c.....END of the MAIN LOOP
      ENDDO
      goto 444
c.............ABnormally finished run: 
  333 CALL TIOS_CNTRL (1, 1)
      call data_out (tenso, nxp, nyp, npt, en) 
c.............normally finished run: 
  444 call close_rstrt
      write (iout, *) 'Finished at step =', nstep
      call enso2date (tenso, id, im, iy)
      write (iout, *) '<enso time> <', tenso, '>' 
      write (iout, *) '<Day:Month:Year> <',id,':',im,':',iy,'>' 
      stop
      end
dyn_mem.f/      849547200   1572  1572  100444  13340     `
#if (defined (INT8) || defined (ALL8))
#define NB_INTW 8
#else
#define NB_INTW 4
#endif

#if (defined (REA8) || defined (ALL8))
#define NB_REAW 8
#else
#define NB_REAW 4
#endif

#if (defined (DBL16) || defined (CRAY))
#define NB_DBLW  16
#else
#define NB_DBLW  8
#endif

c-----------------------------------------------------
      subroutine mem_alloc (p_tr, msize, key, object)
c-----------------------------------------------------
      character*(*) object
      common /all_loc/ memory_used
      byte      bte(1)
      integer   int(1)
      real      flt(1)
      double precision dbl(1)
      pointer (p_tr, tr), (p_flt, flt), (p_int, int), 
     *        (p_bte, bte), (p_dbl, dbl)

      if (msize .le. 0) 
     *     call perror1('mem_alloc: Wrong allocation request...Stop!',1)

      if      (key .eq. 0) then    !! 1-byte allocation
         mem_request = msize
      else if (key .eq. 1) then    !! INTEGER allocation
         mem_request = msize * NB_INTW
      else if (key .eq. 2) then    !! REAL allocation
         mem_request = msize * NB_REAW
      else if (key .eq. 3) then    !! DOUBLE allocation
         mem_request = msize * NB_DBLW
      endif

      p_tr = malloc(mem_request)

      if (p_tr .eq. 0) then
         write (6, *) 'mem_alloc: Out of memory for <', object, '> !!!'
         stop
      endif

      if      (key .eq. 0) then    !! 1-byte allocation
         p_bte = p_tr
         do i = 1, msize
            bte(i) = char(0)
         enddo
      else if (key .eq. 1) then    !! INTEGER allocation
         p_int = p_tr
         do i = 1, msize
            int(i) = 0
         enddo
      else if (key .eq. 2) then    !! REAL allocation
         p_flt = p_tr
c         x = sqrt(-1.)
         do i = 1, msize
            flt(i) = 0.
c            flt(i) = x
c            flt(i) = -987654321.
         enddo
      else if (key .eq. 3) then    !! DOUBLE allocation
         p_dbl = p_tr
         do i = 1, msize
            dbl(i) = 0d0
         enddo
      endif

      memory_used = memory_used + mem_request
c      write(91,*)object,p_tr,msize,mem_request,memory_used

      return
      end

c-------------------------------------------
      subroutine mem_free (p_tr, msize, key)
c-------------------------------------------
      pointer (p_tr, tr)
      common /all_loc/ memory_used

      if (p_tr .eq. 0) then
         write (6, *) 'mem_free: Invalid pointer...Stop!'
         stop
      endif

      call free(p_tr)
      
      if      (key .eq. 0) then    !! 1-byte allocation
         mem_request = msize
      else if (key .eq. 1) then    !! INTERGER allocation
         mem_request = msize * NB_INTW
      else if (key .eq. 2) then    !! REAL allocation
         mem_request = msize * NB_REAW
      else if (key .eq. 3) then    !! DOUBLE allocation
         mem_request = msize * NB_DBLW
      endif
      
      memory_used = memory_used - mem_request
c      write(91,*)'mem_free',p_tr,msize,mem_request,memory_used

      return
      end

c-----------------------------------------------------------
      subroutine mem_realloc (p_old, mold, mnew, mcopy, key)
c-----------------------------------------------------------
      common /all_loc/ memory_used
      byte      b1(1), b2(1)
      integer   i1(1), i2(1)
      real      f1(1), f2(1)
      double precision d1(1), d2(1)
      pointer (p_b1, b1), (p_i1, i1), (p_f1, f1), (p_d1, d1),
     *        (p_b2, b2), (p_i2, i2), (p_f2, f2), (p_d2, d2), 
     *        (p_new, new), (p_old, old)
      
      mmin = min(mold, mnew)
      if (mmin .le. 0)
     *     call perror1('mem_realloc: Wrong rallocation request...Stop!',1)

      if      (key .eq. 0) then    !! 1-byte allocation
         mem_request_new = mnew
         mem_request_old = mold
      else if (key .eq. 1) then    !! INTERGER allocation
         mem_request_new = mnew * NB_INTW
         mem_request_old = mold * NB_INTW
      else if (key .eq. 2) then    !! REAL allocation
         mem_request_new = mnew * NB_REAW
         mem_request_old = mold * NB_REAW
      else if (key .eq. 3) then    !! DOUBLE allocation
         mem_request_new = mnew * NB_DBLW
         mem_request_old = mold * NB_DBLW
      endif

      p_new = malloc(mem_request_new)

      mmin = min(mmin, mcopy)

      if      (key .eq. 0) then !! 1-byte allocation
         p_b1 = p_new
         p_b2 = p_old
         do i = 1, mmin
            b1(i) = b2(i)
         enddo
      else if (key .eq. 1) then !! INTERGER allocation
         p_i1 = p_new
         p_i2 = p_old
         do i = 1, mmin
            i1(i) = i2(i)
         enddo
      else if (key .eq. 2) then !! REAL allocation
         p_f1 = p_new
         p_f2 = p_old
         do i = 1, mmin
            f1(i) = f2(i)
         enddo
      else if (key .eq. 3) then !! DOUBLE allocation
         p_d1 = p_new
         p_d2 = p_old
         do i = 1, mmin
            d1(i) = d2(i)
         enddo
      endif

      call free(p_old)
      p_old = p_new
         
      memory_used = memory_used + mem_request_new - mem_request_old
c      write(91,*)'mem_realloc',p_new,mem_request_new,mem_request_old,memory_used
         
      return
      end

c---------------------------------------------------
      function mem_get ()
c---------------------------------------------------
      common /all_loc/ memory_used
      mem_get = memory_used
      return
      end

c-------------------------------------------------
      subroutine model_memory (nx, ny, nz, npt)   
c-------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_pbl.h'
      include 'comm_diff.h'
 
      nptz = npt * nz
      mptz = npt * max(4,nz)
      nxy  = nx*ny
 
      call mem_alloc (p_u,  mptz, 2, 'u')
      call mem_alloc (p_uc, nptz, 2, 'uc')
      call mem_alloc (p_fu, nptz, 2, 'fu')
      call mem_alloc (p_um, nptz, 2, 'um')
 
      call mem_alloc (p_v,  mptz, 2, 'v')
      call mem_alloc (p_vc, nptz, 2, 'vc')
      call mem_alloc (p_fv, nptz, 2, 'fv')
      call mem_alloc (p_vm, nptz, 2, 'vm')
 
      call mem_alloc (p_w,  nptz, 2, 'w')
      call mem_alloc (p_wm, nptz, 2, 'wm')

      call mem_alloc (p_h,   nptz, 2, 'h')
      call mem_alloc (p_fh,  nptz, 2, 'fh')
      call mem_alloc (p_fhd, nptz, 2, 'fhd')
      call mem_alloc (p_hm,  nptz, 2, 'hm')

      call mem_alloc (p_pgfx, nptz, 2, 'pgf_x')
      call mem_alloc (p_pgfy, nptz, 2, 'pgf_y')
      call mem_alloc (p_corx, nptz, 2, 'cor_x')
      call mem_alloc (p_cory, nptz, 2, 'cor_y')
      call mem_alloc (p_xnl, nptz, 2, 'nonlin_x')
      call mem_alloc (p_ynl, nptz, 2, 'nonlin_y')

#ifdef dump_all
      call mem_alloc (p_vertx, nptz, 2, 'vert_x')
      call mem_alloc (p_verty, nptz, 2, 'vert_y')
      call mem_alloc (p_rhsx, nptz, 2, 'rhs_x')
      call mem_alloc (p_rhsy, nptz, 2, 'rhs_y')
      call mem_alloc (p_crhsx, nptz, 2, 'crhs_x')
      call mem_alloc (p_crhsy, nptz, 2, 'crhs_y')
#endif
 
      call mem_alloc (p_t,  nptz, 2, 'tem')
      call mem_alloc (p_ft, nptz, 2, 'ftem')
      call mem_alloc (p_tp, mptz, 2, 'tp')
      call mem_alloc (p_tm, nptz, 2, 'tm')

      call mem_alloc (p_convn, nptz, 2, 'convn')

      call mem_alloc (p_dens,  nptz, 2, 'dens')
      call mem_alloc (p_pdens,  nptz, 2, 'pdens')
      call mem_alloc (p_densm, nptz, 2, 'densm')
      call mem_alloc (p_dclim, nptz, 2, 'dclim')
      call mem_alloc (p_hclim, 2*nptz, 2, 'hclim')
      call mem_alloc (p_tclim, 2*nptz, 2, 'tclim')

      if (icl_psi.gt.0) then
          call mem_alloc (p_pclim, 2*npt, 2, 'pclim')
      endif

      if (use_salt) then
         call mem_alloc (p_sal,  nptz, 2, 'sal')
         call mem_alloc (p_fsal, nptz, 2, 'fsal')
         call mem_alloc (p_salm, nptz, 2, 'salm')
         call mem_alloc (p_sss,  3*npt,  2, 'sss')
         call mem_alloc (p_ep,   npt,  2, 'ep')
         call mem_alloc (p_sclim, 2*nptz, 2, 'sclim')
      endif

c  2D---------------------------------------------
      if (use_trac) then
         call mem_alloc (p_tr,  nptz*ntrac, 2, 'tr')
         call mem_alloc (p_ftr, nptz*ntrac, 2, 'ftr')
         call mem_alloc (p_trm, nptz*ntrac, 2, 'trm')
      endif

      call mem_alloc (p_area, nptz, 2, 'area')

      call mem_alloc (p_sponge,  npt, 2, 'sponge')
      call mem_alloc (p_relax,  npt, 2, 'relax')

      call mem_alloc (p_f,    npt, 2, 'f')
      call mem_alloc (p_emx,  npt, 2, 'emx')
      call mem_alloc (p_emy,  npt, 2, 'emy')
      call mem_alloc (p_emxy, npt, 2, 'emxy')
      call mem_alloc (p_emx2, npt, 2, 'emx2')
      call mem_alloc (p_emy2, npt, 2, 'emy2')
 
      call mem_alloc (p_taux, npt, 2, 'taux')
      call mem_alloc (p_tauy, npt, 2, 'tauy')
 

      call mem_alloc (p_q,  npt,   2, 'q')
      call mem_alloc (p_qr, npt,   2, 'qr')
      call mem_alloc (p_qb, 5*npt, 2, 'qb')
      call mem_alloc (p_wnd, 3*npt, 2, 'wnd')

      call mem_alloc (p_sst,  3*npt, 2, 'sst')
      call mem_alloc (p_cld,  3*npt, 2, 'cld')
      call mem_alloc (p_solr, 3*npt, 2, 'solr')
      call mem_alloc (p_prcp, 3*npt, 2, 'prcp')
      call mem_alloc (p_dtx,  2*npt, 2, 'dtx')
      call mem_alloc (p_dty,  2*npt, 2, 'dty')
 
      call mem_alloc (p_dept, npt, 2, 'dept')

      call mem_alloc (p_ubar, npt, 2, 'ubar')
      call mem_alloc (p_vbar, npt, 2, 'vbar')

      call mem_alloc (p_uforc, npt, 2, 'uforc')
      call mem_alloc (p_vforc, npt, 2, 'vforc')
      
      call mem_alloc (p_psi,  npt, 2, 'psi')
      call mem_alloc (p_zfu,  npt, 2, 'zfu')
      call mem_alloc (p_zfv,  npt, 2, 'zfv')
      call mem_alloc (p_bdiv, npt, 2, 'bdiv')

      call mem_alloc (p_xm, nx, 2, 'x') 
      call mem_alloc (p_ym, ny, 2, 'y') 
      call mem_alloc (p_xp, nx, 2, 'xp') 
      call mem_alloc (p_yp, ny, 2, 'yp')

      call mem_alloc (p_hsave, nz+1, 2, 'hsave')

      call mem_alloc (p_isk, npt*nz, 1, 'isk')
      call mem_alloc (p_iyk, npt*nz, 1, 'iyk')
      call mem_alloc (p_isxk, npt*nz, 1, 'isyk')
      call mem_alloc (p_isyk, npt*nz, 1, 'isyk')
      call mem_alloc (p_nzi, npt, 1, 'nzi')
      call mem_alloc (p_nzi_b, npt, 1, 'nzi_b')

      if (use_wnsp) then
         call mem_alloc (p_wnsp,  2*npt, 2, 'wnsp')         
      endif
      if (initq .eq. 8 .or. use_ice) then
         call mem_alloc (p_uwnd,  2*npt, 2, 'uwnd')         
         call mem_alloc (p_vwnd,  2*npt, 2, 'vwnd')         
         call mem_alloc (p_ahum,  3*nxy, 2, 'ahum')         
         call mem_alloc (p_atem,  3*nxy, 2, 'atem')         
         call mem_alloc (p_amhum,   nxy, 2, 'amhum')         
         call mem_alloc (p_amth,    nxy, 2, 'amth')         
      endif
      if (use_ice) then
         call mem_alloc (p_rh,   nxy, 2, 'rh')         
         call mem_alloc (p_pp,   npt, 2, 'pp')         
         call mem_alloc (p_qios, npt, 2, 'qios')         
         call mem_alloc (p_brne, npt, 2, 'brne')         
         call mem_alloc (p_hice, npt, 2, 'hice')         
         call mem_alloc (p_cice, npt, 2, 'cice')         
         call mem_alloc (p_thice,npt, 2, 'thice')         
         call mem_alloc (p_tsnw, nxy, 2, 'tsnw')         
         call mem_alloc (p_rlhi, nxy, 2, 'rlhi')         
         call mem_alloc (p_shi,  nxy, 2, 'shi')         
         call mem_alloc (p_qlwi, nxy, 2, 'qlwi')         
         call mem_alloc (p_qswi, nxy, 2, 'qswi')         
      endif
      if (use_diffiso) then
         call mem_alloc (p_gtrz, nptz, 2, 'gtr2')         
         call mem_alloc (p_slx, nptz, 2, 'slx')         
         call mem_alloc (p_sly, nptz, 2, 'sly')         
         call mem_alloc (p_trx, nptz, 2, 'trx')         
         call mem_alloc (p_try, nptz, 2, 'try')         
         call mem_alloc (p_trz, nptz, 2, 'trz')         
         call mem_alloc (p_psix,nptz, 2, 'psix')         
         call mem_alloc (p_psiy,nptz, 2, 'psiy')         
         call mem_alloc (p_sigx,nptz, 2, 'sigx')         
         call mem_alloc (p_sigy,nptz, 2, 'sigy')         
         call mem_alloc (p_sigz,nptz, 2, 'sigz')         
         call mem_alloc (p_gtr, npt, 2, 'gtr1')         
         call mem_alloc (p_dxm2, npt, 2, 'dxm')         
         call mem_alloc (p_dym2, npt, 2, 'dym')         
         call mem_alloc (p_dxm, npt, 2, 'dxm')         
         call mem_alloc (p_dym, npt, 2, 'dym')         
         call mem_alloc (p_dxp, npt, 2, 'dxm')         
         call mem_alloc (p_dyp, npt, 2, 'dym')         
         call mem_alloc (p_csy, npt, 2, 'csy')         
         call mem_alloc (p_csyc, npt, 2, 'csy')         
      endif

      call mem_alloc (p_wint, nz*ny, 2, 'zonal ave w')
      call mem_alloc (p_psiw, (nz+1)*ny, 2, 'meridional sf')

      return
      end

c--------------------------------------
      subroutine datagrid_memory (tmp)
c--------------------------------------
      dimension tmp(1)
      include 'comm_new.h'
      include 'comm_data.h'
 
      call mem_alloc (p_xd, mxp, 2, 'xd')
      do i = 1, mxp
         xd(i) = tmp(i)
      enddo

      call mem_alloc (p_yd, myp, 2, 'yd')
      do i = 1, myp
         yd(i) = tmp(mxp+i)
      enddo

c.....shift SEGMENTS array to begining of tmp
      do i = 1, mseg
         tmp(i) = tmp(mxp+myp+i)
      enddo

      call mem_alloc (p_ixd,  mxp*myp, 1, 'ixd')
      call mem_alloc (p_im2d, npt2, 1, 'im2d')
      call mem_alloc (p_blcf, 4*npt2, 2, 'blcf')
      
      idatgr = 1
      
      return
      end
dyn_new.f/      849548450   1572  1572  100666  42144     `
c$Source: /usr/our/senya/work/model/MC_PG/senq/RCS/dyn_new.f,v $
c$Author: senya $
c$Revision: 0.4 $
c$Date: 94/01/24 11:04:47 $
c$State: Exp $
c     idig.f / "uphi" - model/
c--------------------------------------
      function idig(xxxxx, n)
      integer xxxxx, n, res
      integer idig
c
      res = xxxxx
      if (n .gt. 1) res = xxxxx / 10**(n-1)
      idig = mod (res, 10)

      return
      end

      function mlen (string)
c---------------------------
      character*(*) string
      integer mlen
      data LMAX /80/

      k = 1

      do while (
     *     k .le. LMAX            .and.
     *     int(string(k:k)) .ge. 33 .and.
     *     int(string(k:k)) .le. 126)
         k = k + 1
      enddo
      
      mlen = k-1
      return
      end

c     ------------------------------------------------------------------
      subroutine inout (ioin)
c     ------------------------------------------------------------------
c     unix routine for opening the input parameter file and the output
c     logfil from the command line arguments.

      include 'comm_new.h'
      character*80 arg
      
      narg = iargc()

      i  = 0
      in = 0
      do while (i .lt. narg)
         i = i + 1
         call getarg (i, arg)
         if (arg .eq. '-h' .or. arg .eq. '-help') then
            goto 100
         elseif (arg .eq. '-i') then
            i = i + 1
            call getarg (i, finp)
            open (unit = ioin, file = finp)
            fout = finp(1:mlen(finp))//'.log'
            fcpu = finp(1:mlen(finp))//'.cpu'
            ftios = '.tios\0'
            in = 1
         elseif (arg .eq. '-o') then
            i = i + 1
            call getarg (i, fout)
         elseif (arg .eq. '-t') then
            i = i + 1
            call getarg (i, ftios)
         elseif (arg .eq. '-d') then
            i = i + 1
            call getarg (i, fbi)
            n_in = mlen(fbi)
            call dump_rstrt
            stop
         endif
      enddo

      if (in .eq. 0) goto 100

      open (unit = iout, file = fout)
      goto 200

  100 call getarg (0, arg)
      write (6, *) 
     *     'usage: '//arg(1:mlen(arg))//' [-i file][-t ftios][-d file]'
      write (6,*) 'where: -i file - for model control <file>'
      write (6,*) '       -t file - for tios control <file> (deflt:<.tios>)'
      write (6,*) '       -d file - make a dump of data/restart <file>'
      stop

  200 return
      end

c     ------------------------------------------------------------------
      subroutine ddiv (npt,nzi,uc,vc,emx,emy,emxy,w,fhd,lxxk,lyyk,lxyk,lyxk,
     *       snxk,snyk,isyk,isk,tp,mbc,lpbcwk,lpbcek,h,bdiv)
csenq ------------------------------------------------------------------
c     compute the divergence (fhd) for all layers and put the Sum in w(1,nz).
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch

      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz)
      dimension uc(npt,nz),vc(npt,nz),emx(npt),emy(npt),emxy(npt),w(npt,nz),
     *     fhd(npt,nz), tp(npt,4),h(npt,nz), bdiv(npt), nzi(npt)
c
c     set boundary condition flag based on whether interior corners are
c     treated as boundaries.  see bcset and dfdx.
c
      nbu = 0
      nbv = 0
      if(mbc.eq.1 .or. mbc.eq.4) nbu = 1
      if(mbc.eq.1 .or. mbc.eq.3) nbv = 1


c........compute d(hv)/dy & d(hu)/dx..
      nxk = nbxk(1)
      nyk = nbyk(1)
      nck = ncsk(1)
      npbk = npbck(1)
      call dfdx1(uc,tp(1,3),npt,nbu,nxk,nyk,nck,lxxk,lyxk,
     *     snxk,npbk,lpbcwk,lpbcek)
      call dfdy1(vc,tp(1,4),npt,nbv,nyk,nxk,nck,
     *     lyyk,lxyk,snyk,isyk)

      if (mgrid .ne. 2) then
         do i = 1, npt
            fhd(i,1) = emx(i)*tp(i,3) + emy(i)*tp(i,4)
         enddo
      else
         do i = 1, npt
            fhd(i,1) = emx(i)*tp(i,3) + emy(i)*tp(i,4) + emxy(i)*vc(i,1)
         enddo
      endif
      
      do k = 2, nz
         npk = nptk(k)
c........mud points have zero transport:
         call zero_em (npt, tp)
         call zero_em (npt, tp(1,2))
         do j = 1, npk
            i = isk(j,k)
            tp(i,1) = uc(i,k)
            tp(i,2) = vc(i,k)
         enddo
         call dfdx1(tp,tp(1,3),npt,nbu,nxk,nyk,nck,lxxk,lyxk,
     *       snxk,npbk,lpbcwk,lpbcek)
         call dfdy1(tp(1,2),tp(1,4),npt,nbv,nyk,nxk,nck,
     *        lyyk,lxyk,snyk,isyk)

c........now multiply by the appropriate scale factors to find divergence.
c........div(u) = (1/mx)*(du/dx) + (1/my)*(dv/dy) + myx*u + mxy*v
c........we also accumulate the sum of layer divergences in w(nz)
         if (mgrid .ne. 2) then
            do i = 1, npt
               fhd(i,k) = emx(i)*tp(i,3) + emy(i)*tp(i,4)
            enddo
         else
            do i = 1, npt
               fhd(i,k) = emx(i)*tp(i,3) + emy(i)*tp(i,4) + 
     *                    emxy(i)*tp(i,2) 
            enddo
         endif
      enddo

      do i = 1, npt
         mz = nzi(i)
         fhd(i,1) = fhd(i,1) - h(i,1)*bdiv(i)
c         w(i,1) = fhd(i,1)
         do k = 2, mz
            fhd(i,k) = fhd(i,k) - h(i,k)*bdiv(i)
c            w(i,k) = w(i,k-1) + fhd(i,k)
         enddo
      enddo

      return
      end

c     ----------------------------------------------------------
      subroutine wtop (npt, w, fhd, fh, h, ncyc, istep, dnt)
c     ----------------------------------------------------------
      include 'comm_new.h'
c.....subroutine to set W at first interface.
      dimension fhd(1), w(1), fh(1), h(1)

      if (imix .eq. 4) then

         if     (mix_wtop .eq. 1) then 
            do i = 1, npt
               w(i) = 0.
            enddo

         elseif (mix_wtop .eq. 2) then

            binv1  = real(ncyc-istep)/dnt
            do i = 1, npt
               
               dmin = fh(i) + binv1 * (h(i) - hmax_mix)
               dmax = fh(i) + binv1 * (h(i) - hmin_mix)
               divw = fhd(i)
               divw = amin1(divw, dmax)
               divw = amax1(divw, dmin)
               
               w(i) = fhd(i) - divw
            enddo
         endif

      else

         if     (iv_top .eq. 1) then
            do i = 1, npt
               w(i) = fhd(i)
            enddo

         elseif (iv_top.eq.3) then
            do i = 1, npt
               w(i) = 0.
            enddo
         endif
         
      endif

      return
      end

c     ------------------------------------------------------------------
      subroutine dwcal (npt, nz, nsig, nzi, w, fhd, sigma)
c     ------------------------------------------------------------------
c.....find w(k+1/2) at each intermideate sigma-layer interface 
c.....uses sum of div() from w(nz)
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension w(npt,nz),fhd(npt,nz),sigma(nz),nzi(npt)

      do i = 1, npt
         win =  - fhd(i,1) + w(i,1)
         do k = 2, nzi(i) - 1
            w(i,k) = w(i,k-1) + fhd(i,k) - 1.5*(sigma(k)+sigma(k+1))*win
         enddo
c to check that w(k=last) = 0.
c         k = nzi(i)
c         w(i,k) = w(i,k-1) + fhd(i,k) - 1.5*sigma(k)*win
      enddo

      return
      end

c     ------------------------------------------------------------------
      subroutine vertu (npt,nz,nsig,nzi,nzi_b,bint,taux,tauy,u,v,w,h,
     *                  fu,fv,fh,vertx,verty,zfu,zfv)
c-----------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension bint(1), taux(npt), tauy(npt), u(npt,nz),v(npt,nz), 
     *          w(npt,nz), h(npt,nz), fu(npt,nz), fv(npt,nz), nzi(npt)
     *     , zfu(npt), zfv(npt), nzi_b(npt), fh(npt,nz)
#ifdef dump_all
     *     , vertx(npt,nz), verty(npt,nz)
#endif
      
c.....surface layer:
#ifdef dump_all
      do i = 1, npt
         do k = 1, nz
            vertx(i,k) = 0.
            verty(i,k) = 0.
         enddo
      enddo
#endif

      do i = 1, npt
         fu(i,1) = fu(i,1) + taux(i)
         fv(i,1) = fv(i,1) + tauy(i)
      enddo

      do k = 1, nsig
         k1 = k + 1
         do i = 1, npt
            w_add = w(i,k)
            fh(i,k)  = fh(i,k)  + w_add
            fh(i,k1) = fh(i,k1) - w_add
         enddo
      enddo

c.....going by layer interfaces:
        
      do i = 1, npt
         mz = nzi(i)
         dz = h(i,1)
         do k = 1, mz - 1
            b2 = bint(k)
            k1 = k + 1
            dz = 2.*h(i,k) - dz
            h_ave = b2/dz
            u_ave = 0.5*(u(i,k) + u(i,k1))
            v_ave = 0.5*(v(i,k) + v(i,k1))
            
            w_add = w(i,k)
            u_add = h_ave*(u(i,k1) - u(i,k)) + w_add*u_ave
            v_add = h_ave*(v(i,k1) - v(i,k)) + w_add*v_ave

            fu(i,k)  = fu(i,k)  + u_add
            fu(i,k1) = fu(i,k1) - u_add

            fv(i,k)  = fv(i,k)  + v_add
            fv(i,k1) = fv(i,k1) - v_add

            if (k.eq.nzi_b(i)) then
               zfu(i) = zfu(i) + u_add
               zfv(i) = zfv(i) + v_add
            endif
#ifdef dump_all
            vertx(i,k) = vertx(i,k) + u_add
            vertx(i,k1) = vertx(i,k1) + -u_add
            verty(i,k) = verty(i,k) + v_add
            verty(i,k1) = verty(i,k1) - v_add
#endif
         enddo
      enddo

      return
      end
      
      subroutine vertt (npt,nz,nzi,cint,q,qr,w,h,t,ft)
c----------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'diffiso.h'
      dimension cint(nz),q(npt),qr(npt),w(npt,nz),h(npt,nz),
     *          t(npt,nz),ft(npt,nz),tp(1)
      dimension nzi(npt)
      parameter (H_ATT1 = -1./17.)

      do i = 1, npt
         ft(i,1) = ft(i,1) + q(i) + qr(i)

         dz = h(i,1)
         do k = 1, nzi(i) - 1
            dz = 2.*h(i,k) - dz
            k1 = k + 1
            c2 = cint(k)
            tk  = t(i,k)
            tk1 = t(i,k1)
            h_ave = c2/dz

            wik = w(i,k)
            ck = cupi_ts
            ck1 = 1.- ck
            if (wik.lt.0) then
               ck  = ck1
               ck1 = cupi_ts
            endif
            t_ave = ck*tk + ck1*tk1
            t_add = h_ave*(tk1 - tk) + wik*t_ave
            
            ft(i,k)  = ft(i,k)  + t_add 
            ft(i,k1) = ft(i,k1) - t_add 
         enddo

      enddo

      if (isolrp .eq. 1) then
c.....add penetrating solar radiation:
         do i = 1, npt
            z = 0.
            do k = 1, nzi(i) - 1
               k1 = k + 1
               z = z + h(i,k)
               t_add = qr(i)*exp(H_ATT1*z)
               
               ft(i,k)  = ft(i,k)  - t_add 
               ft(i,k1) = ft(i,k1) + t_add 
            enddo
         enddo
      endif

      return
      end

      subroutine vertts (npt,nz,nzi,cint,q,qr,ep,w,h,t,ft,s,fs)
c-------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'diffiso.h'
      dimension cint(nz), q(npt), qr(npt), ep(npt), w(npt,nz), h(npt,nz), 
     *     t(npt,nz), ft(npt,nz), s(npt,nz), fs(npt,nz), tp(1)
      dimension nzi(npt)
      parameter (H_ATT1 = -1./17.)

      do i = 1, npt
         ft(i,1) = ft(i,1) + q(i) + qr(i)
         fs(i,1) = fs(i,1) + ep(i) 

         dz = h(i,1)
         do k = 1, nzi(i) - 1
            dz = 2.*h(i,k) - dz
            k1 = k + 1
            c2 = cint(k)

            h_ave = c2/dz
            tk  = t(i,k)
            tk1 = t(i,k1)
            sk  = s(i,k)
            sk1 = s(i,k1)

            wik = w(i,k)

            ck = cupi_ts
            ck1 = 1.- ck
            if (wik.lt.0) then
               ck = ck1
               ck1 = cupi_ts
            endif
            t_ave = ck*tk + ck1*tk1
            s_ave = ck*sk + ck1*sk1
               
            t_add = h_ave*(tk1 - tk) + wik*t_ave
            s_add = h_ave*(sk1 - sk) + wik*s_ave
            
            ft(i,k)  = ft(i,k)  + t_add 
            ft(i,k1) = ft(i,k1) - t_add 
            fs(i,k)  = fs(i,k)  + s_add 
            fs(i,k1) = fs(i,k1) - s_add 
         enddo
      enddo

      if (isolrp .eq. 1) then
c.....add the penetrating solar radiation:
         do i = 1, npt
            z = 0.
            do k = 1, nzi(i) - 1
               k1 = k + 1
               z = z + h(i,k)
               t_add = qr(i)*exp(H_ATT1*z)
               
               ft(i,k)  = ft(i,k)  - t_add 
               ft(i,k1) = ft(i,k1) + t_add 
            enddo
         enddo
      endif

      return
      end

      subroutine verttr (npt,nz,nzi,cint,w,h,tr,ftr)
c-------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'diffiso.h'
      dimension cint(nz), w(npt,nz), h(npt,nz), tr(npt,nz,1), ftr(npt,nz,1)
      dimension nzi(npt)
      parameter (H_ATT1 = -1./17.)

      do i = 1, npt
         dz = h(i,1)
         do k = 1, nzi(i) - 1
            dz = 2.*h(i,k) - dz
            k1 = k + 1
            c2 = cint(k)
            
            h_ave = c2/dz
            wik = w(i,k)
            ck = cupi_tr
            ck1 = 1.- ck
            if (wik.lt.0) then
               ck = ck1
               ck1 = cupi_tr
            endif
            
            do n = 1, ntrac
               trk  = tr(i,k,n)
               trk1 = tr(i,k1,n)
               tr_ave = ck*trk + ck1*trk1
               
               tr_add = h_ave*(trk1 - trk) + wik*tr_ave
               
               ftr(i,k,n)  = ftr(i,k,n)  + tr_add 
               ftr(i,k1,n) = ftr(i,k1,n) - tr_add 
            enddo
         enddo
      enddo
      
      return
      end

      subroutine enso2date (enso, id, im, iy)
c----------------------------------------------------
#define LEAP_YEAR(y) (mod(y,4) .eq. 0)
      integer*2 norm(12)
      data norm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/

      iy = 1960 + jint(enso/12.)

      res = enso - (iy - 1960.)*12.
      im = jint(res) + 1

      if (im .eq. 2 .and. LEAP_YEAR(iy) ) then
         id = 1 + int(29 * (res - int(res)))
      else
         id = 1 + int(norm(im) * (res - int(res)))
      endif

      return
      end

      function date2enso (id, im, iy)
c--------------------------------------
#define LEAP_YEAR(y) (mod(y,4) .eq. 0)
      integer*2 norm(12)
      data norm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/

      if (im .eq. 2 .and. LEAP_YEAR(iy) ) then
         date2enso = (iy - 1960.) * 12. + 1. + real((id-1))/29.  
      else
         date2enso = (iy - 1960.) * 12. + real(im-1) + real((id-1))/norm(im) 
      endif

      return
      end

      subroutine DayOfYear(enso, idoy, idiy)
c------------------------------------------------
#define LEAP_YEAR(y) (mod(y,4) .eq. 0)
      integer*2 norm(12)
      data norm /0, 31, 59, 90,120,151,181,212,243,273,304,334/

      call enso2date(enso, id, im, iy)

      if (LEAP_YEAR(iy)) then
         idiy = 366
      else
         idiy = 365
      endif

      if (im .gt. 2 .and. LEAP_YEAR(iy) ) then
         idoy = norm(im) + id + 1
      else
         idoy = norm(im) + id 
      endif

      return
      end

      subroutine enso2res (renso, id, im, iy)
c----------------------------------------------------
#define LEAP_YEAR(y) (mod(y,4) .eq. 0)
      integer*2 norm(12)
      data norm /31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31/

      iy = jint(renso/12.)

      res = renso - real(12*iy)
      im = jint(res)
      
      res = abs(res - real(im))
      id = jint(res*norm(im+1))

      return
      end

c     ------------------------------------------------------------------
      subroutine knergy(npt,nz,nptk,isk,area,basin,h,u,v,en)
c     ------------------------------------------------------------------
c     subroutine to compute the kinetic energy
c
c     the kinetic energy is given by
c       k.e. = sum < 1/2 h(k)*u(k)^2 >.
c
c     en(1,k) = (output) kinetic energy for layer k.
c     en(2,k) = not used

c     note: area(i) = .5*dx*dy
c     note: basin = sum(area)  (i.e., half the surface area)
c
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension u(npt,1),v(npt,1),h(npt,1),area(npt,nz),en(npten,1),
     *          nptk(1),isk(npt,1),basin(nz)

c........Compute the Kinetic Energy, each layer and total

      eksum = 0.0
      do k = 1, nz
         ek = 0.0
         do j = 1, nptk(k)
            i = isk(j,k)
            uu = u(i,k)
            vv = v(i,k)
            ek = ek + area(i,k) * h(i,k) * (uu*uu + vv*vv)
         enddo

         en(1,k)= 0.5 * ek / basin(k)
         eksum = eksum + en(1,k)
      enddo

      en(1,nz+1) = eksum

      return
      end

c     ------------------------------------------------------------------
      subroutine pnergy (ifrst,npt,nptk,nz,isk,h,area,t,dens,w,basin,en,tp)
c     ------------------------------------------------------------------
c     subroutine to compute the potential energy, the heat content,
c     and the temperature variance and total mass.
c     en(k,3) = (output) Potential Energy for layer k.
c     en(k,4) = (output) Heat Content for layer k.
c     en(k,5) = (output) Mass Content for layer k.
c     en(k,6) = (output) Volume for layer k.
c       p.e. = sum <h(k)b(k)(sum h(j)+h(k)/2)> - 1/2 g <z(t)**2>,
c                                      b(k) = alpha*g*(t(k)-t(b))
c       Heat Content         = sum <h(k)*b(k)>
c       Mass Content         = sum <h(k)*dens(k)>
c       Volume               = sum <h(k)>
c
      include 'comm_para.h'
      include 'comm_new.h'

      logical ifrst
      dimension h(npt,1),area(npt,nz),t(npt,1),dens(npt,1),w(npt,1),
     *          en(npten,1), tp(1), tmp(npt,1), nptk(1), isk(npt,1),basin(nz)
      pointer (ptmp, tmp)

      if (use_salt) then
         ptmp  = loc(dens)
         base  = SITUD_BOT
         shift = 1000.
      else
         ptmp  = loc(t)
         base  = TEMP_BOT
         shift = 1.
      endif

      do i = 1, npt
         tp(i) = h(i,1)
      enddo

      epsum = 0.
      hcsum = 0.
      wcsum = 0.
      vlsum = 0.
c.......................integrate over each layer.
      do k = 1, nz
         epk = 0.
         hck = 0.
         wck = 0.
         vlk = 0.
         do j = 1, nptk(k)
            i = isk(j,k)
            hk   = h(i,k)
            ahk  = area(i,k) * hk
            ahbk = ahk * (tmp(i,k) - base)

            epk = epk + ahbk * (hk - w(i,nz) + tp(i))
            hck = hck + ahbk
            wck = wck + ahk * (shift + tmp(i,k)) 
            vlk = vlk + ahk
         enddo

         en(3,k) = epk
         en(4,k) = hck
         en(5,k) = wck
         en(6,k) = vlk

         epsum = epsum + epk
         hcsum = hcsum + hck
         wcsum = wcsum + wck
         vlsum = vlsum + vlk

c find 2*(sum h(j)+h(k)/2) for the next layer.

         if (k .lt. nz) then
            do j = 1, nptk(k)
               i = isk(j,k)
               tp(i) = tp(i) + h(i,k) + h(i,k+1)
            enddo
         endif
      enddo

      if ( ifrst ) then
         epf1 = 1./epsum
         hcf1 = 1./hcsum
         wcf1 = 1./wcsum
         vlf1 = 1./vlsum
      endif

      do k = 1, nz
         en(3,k) = epf1 * en(3,k)
         en(4,k) = hcf1 * en(4,k)
         en(5,k) = wcf1 * en(5,k)
         en(6,k) = vlf1 * en(6,k)
      enddo
      en(3,nz+1) = epf1 * epsum 
      en(4,nz+1) = hcf1 * hcsum 
      en(5,nz+1) = wcf1 * wcsum 
      en(6,nz+1) = vlf1 * vlsum

      return
      end
c
      subroutine vel_updat(npt,nz,nzi,binv,abinv,uc,vc,fu,fv)
c     ----------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension uc(npt,nz),vc(npt,nz),fu(npt,nz),fv(npt,nz),nzi(npt)

      do i = 1, npt
         do k = 1, nzi(i)
            uc(i,k) = uc(i,k) + binv*fu(i,k)
            vc(i,k) = vc(i,k) + binv*fv(i,k)
            fu(i,k) = abinv*fu(i,k)
            fv(i,k) = abinv*fv(i,k)
         enddo
      enddo
      return
      end

c     ------------------------------------------------------------------
      subroutine dhoriz(npt,u,v,uc,vc,f,fu,fv,fhd,emx,emy,emxy,tp,mbc,zfu,zfv,
     *     lxxk,lyyk,lxyk,lyxk,snxk,snyk,isyk,isk,lpbcwk,lpbcek,nzi
     *     ,corx,cory,xnl,ynl,fh,nonlin_baro)
c     ------------------------------------------------------------------
c     subroutine that calculates the horizontal terms in the momentum
c     equation.  e.g. the coriolis terms and the horizontal advection
c     terms.
c
c     npt    = (input)  # of grid points per model layer (nxyc or nxy).
c     u,v    = (input)  zonal & merid. velocity for time step n.
c     uc,vc  = (input)  mass transport.
c     fu,fv  = (input/output)  update transport arrays
c     emx,emy= (input)  factor for x,y-differencing, d(psix)/dx*1/delx.
c     lxx,...= (input)  nbx+ncs indices of the ocean x,y-segment end points 
c     snx,sny= (input)  nbx+ncs signs (+1 or -1) 
c     isy    = (input)  indices to convert from an x-sort to a y-sort.
c     tp     = (input)  temporary space.
c     mbc    = (input)  type of boundary condition on u and v
c
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/friction/b_fric

      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)

      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      dimension u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz),f(npt),fu(npt,nz),fv(npt,nz),
     *     emx(npt),emy(npt),emxy(npt), tp(npt,1), zfu(npt), zfv(npt), fhd(npt,nz)
     *     , corx(npt,nz), cory(npt,nz)
     *     , xnl(npt,nz), ynl(npt,nz), fh(npt,nz)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),nzi(npt)
c
c     set boundary condition flag for differencing at or near the
c     boundary.
c
c     for cases where the derivative is in the direction to the flow
c     for the cases where u slips along zonal boundaries (mbc=2,3),
c     interior corners are not used.
c
      nbu = 0
c
c     for no-slip everywhere (mbc=1) or at zonal boundaries (mbc=0),
c     interior corners are used for a one-sided difference.
c
      if(mbc.eq.1 .or. mbc.eq.4) nbu = 1
c
c     for the cases where v slips along meridional boundaries (mbc=2,4),
c     interior corners are not used.
c
      nbv = 0
c
c     for no-slip everywhere (mbc=1) or at meridional boundaries
c     (mbc=3), interior corners are used.
c
c.....update fh in sigma layers:
      do k = 1, nsig
         do i = 1, npt
            fh(i,k) = fh(i,k) - fhd(i,k)
         enddo
      enddo

      if(mbc.eq.1 .or. mbc.eq.3) nbv = 1

      do k = 1, nz
         npk = nptk(k)
         nxk = nbxk(k)
         nyk = nbyk(k)
         nck = ncsk(k)
         npbk = npbck(k)

c.....add coriolis terms:
         do j = 1, npk
            i = isk(j,k)
            tmp     = f(i)*vc(i,k) 
            fu(i,k) = fu(i,k) + tmp
            corx(i,k) = tmp
            tmp     = -f(i)*uc(i,k) 
            fv(i,k) = fv(i,k) + tmp
            cory(i,k) = tmp
         enddo

c.....add d(hu^2)/dx 
         do j = 1,npk
            i = isk(j,k)
            tp(i,2) = uc(i,k)*u(i,k)
            ynl(i,k) = 0.
         enddo

         call dfdxk(tp(1,2),tp,npt,npk,nbu,nxk,nyk,nck,lxxk(1,k),lyxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k))
         do j = 1, npk
            i = isk(j,k)
            tmp = emx(i)*tp(i,1)
            fu(i,k) = fu(i,k) - tmp
            xnl(i,k) = -tmp
         enddo
         if (mgrid .eq. 2) then
            do j = 1, npk
               i = isk(j,k)
               tmp = emxy(i)*tp(i,2)
               fv(i,k) = fv(i,k) + tmp
               ynl(i,k) = +tmp
            enddo
         endif

c.....find dv**2h/dy 
         do j = 1, npk
            i = isk(j,k)
            tp(i,2) = vc(i,k)*v(i,k)
         enddo
         call dfdyk(tp(1,2),tp,npt,npk,nbv,nyk,nxk,nck,lyyk(1,k),lxyk(1,k),
     *        snyk(1,k),isyk(1,k))

         do j = 1, npk
            i = isk(j,k)
            tmp = emy(i)*tp(i,1)
            fv(i,k) = fv(i,k) - tmp
            ynl(i,k) = ynl(i,k)-tmp
         enddo
         if (mgrid .eq. 2) then
            do j = 1, npk
               i = isk(j,k)
               tmp = emxy(i)*tp(i,2)
               fv(i,k) = fv(i,k) - tmp
               ynl(i,k) = ynl(i,k)-tmp
            enddo
         endif

c.....find d(u*h*v)/dx 
         do j = 1, npk
            i = isk(j,k)
            tp(i,3) = uc(i,k)*v(i,k)
         enddo

         call dfdxk(tp(1,3),tp,npt,npk,1,nxk,nyk,nck,lxxk(1,k),lyxk(1,k),
     *         snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k))
         do j = 1, npk
            i = isk(j,k)
            tmp = emx(i)*tp(i,1)
            fv(i,k) = fv(i,k) - tmp
            ynl(i,k) = ynl(i,k)-tmp
         enddo

c.....find d(u*h*v)/dy 
         call dfdyk(tp(1,3),tp,npt,npk,1,nyk,nxk,nck,lyyk(1,k),lxyk(1,k),
     *         snyk(1,k),isyk(1,k))
         do j = 1, npk
            i = isk(j,k)
            tmp = emy(i)*tp(i,1)
            fu(i,k) = fu(i,k) - tmp
            xnl(i,k) = xnl(i,k)-tmp
         enddo
         if (mgrid .eq. 2) then
            do j = 1, npk
               i = isk(j,k)
               tmp = 2.*emxy(i)*tp(i,3)
               fu(i,k) = fu(i,k) - tmp
               xnl(i,k) = xnl(i,k)-tmp
            enddo
         endif
      enddo

c..... add bottom drag, 
c        but don't include in barotropic where it is an implicit term
      do i = 1, npt
         k = nzi(i)
            
         bfric = b_fric * u(i,k)
         fu(i,k) = fu(i,k) - bfric
         zfu(i)  = zfu(i) - bfric
         
         bfric = b_fric * v(i,k)
         fv(i,k) = fv(i,k) - bfric
         zfv(i)  = zfv(i) - bfric
      enddo
      
      do i = 1, npt
         mz = nzi(i)
         do k = 1, mz
            zfu(i) = zfu(i) + corx(i,k)
            zfv(i) = zfv(i) + cory(i,k)
         enddo
      enddo

      if (nonlin_baro.eq.0) then  ! don't send nonlinear stuff to barotropic
         do i = 1, npt
            mz = nzi(i)
            do k = 1, mz
               zfu(i) = zfu(i) + xnl(i,k)
               zfv(i) = zfv(i) + ynl(i,k)
            enddo
         enddo
      endif

      return
c     end of dhoriz.
      end

c     ------------------------------------------------------------------
      subroutine thoriz(npt,uc,vc,t,ft,fhd,emx,emy,lxxk,lyyk,lxyk,lyxk,
     *        snxk,snyk,isyk,isk,lok,tp,mbc,lpbcwk,lpbcek)
c     ------------------------------------------------------------------
c     note: mtc is not used in this version of the code.  rather
c     n.grad(t)=0 is set at all closed boundaries.  at open boundaries
c     determined in the input grid file (see rdgrid), the temperature
c     derivative is not zeroed and t is set in tbcset.
c
c     subroutine that calculates the horizontal terms in the
c     temperature equation.
c
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension uc(npt,nz),vc(npt,nz),t(npt,nz),ft(npt,nz),emx(npt),emy(npt),
     *          tp(npt,3),fhd(npt,nz)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz)
c
c     in order to impose the zero heat flux condition at the boundaries
c     the divergence operator is broken up.
c
c     set boundary condition flag for differencing the mass transport
c     at or near the boundary in the direction of the flow.
c
c     for the cases where u slips along zonal boundaries (mbc=2,3),
c     interior corners are not used.
c
      nbu = 0
c
c     for no slip everywhere (mbc=1) or at zonal boundaries (mbc=4),
c     interior corners are used for a one-sided difference.
c
      if(mbc.eq.1 .or. mbc.eq.4) nbu = 1
c
c     for the cases where v slips along meridional boundaries
c     (mbc=2,4), interior corners are not used.
c
      nbv = 0
c
c     for no slip everywhere (mbc=1) or at meridiional boundaries
c     (mbc=3), interior corners are used.
c
      if(mbc.eq.1 .or. mbc.eq.3) nbv = 1
c
      do k = 1, nz
         npk = nptk(k)
         nxk = nbxk(k)
         nyk = nbyk(k)
         nck = ncsk(k)
         npbk = npbck(k)
         nok = nlok(k)
c.....compute dt/dx (dt/dx=0 at x-boundaries)
         call dfdxk(t(1,k),tp,npt,npk,0,nxk,nyk,nck,lxxk(1,k),lyxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k))
         call zerodt(tp,nok,lok(1,k),nxk,lxxk(1,k),tp(1,3))

c.....compute dt/dy (dt/dy=0 at y-boundaries)
         call dfdyk(t(1,k),tp(1,2),npt,npk,0,nyk,nxk,nck,lyyk(1,k),lxyk(1,k),
     *        snyk(1,k),isyk(1,k))
         call zerodt(tp(1,2),nok,lok(1,k),nyk,lyxk(1,k),tp(1,3))

c.....update the heat content array.
         do j = 1, npk
            i = isk(j,k)
            ft(i,k) = ft(i,k)-(emx(i)*uc(i,k)*tp(i,1) + emy(i)*vc(i,k)*tp(i,2)) 
            ft(i,k) = ft(i,k) - t(i,k)*fhd(i,k)
         enddo
      enddo

      return
c     end of thoriz.
      end
c

      subroutine zero_em (n, a)
c--------------------------------
      dimension a(1)
      do i = 1, n
         a(i) = 0.0
      enddo
      return
      end

      subroutine copya2b (n, a, b)
c--------------------------------
      dimension a(1), b(1)
      do i = 1, n
         b(i) = a(i)
      enddo
      return
      end

c     ------------------------------------
      subroutine decap(npt, nz, nzi, u,v,uc,vc,h)
c     ------------------------------------
c     subroutine to convert horizontal transport to horizontal velocity.
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz),h(npt,nz),nzi(npt)
c
      do i = 1, npt
         do k = 1, nzi(i)
            hinv = 1./h(i,k)
            u(i,k) = uc(i,k)*hinv
            v(i,k) = vc(i,k)*hinv
         enddo
      enddo

      return
      end

c     ------------------------------------------------------------------
      subroutine capfrm(npt,nz,nzi, u,v,uc,vc,h)
c     ------------------------------------------------------------------
c     subroutine to convert velocities to transport. 
c
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      dimension u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz),h(npt,nz),nzi(npt)
c
      do i = 1, npt
         do k = 1, nzi(i)
            hk = h(i,k)
            uc(i,k) = u(i,k)*hk
            vc(i,k) = v(i,k)*hk
         enddo
      enddo

      return
c     end of capfrm.
      end

c     -------------------------------------
      subroutine tdecap(npt, nz, nzi, t, h)
c     -------------------------------------
c.....convert heat content to temperature.
      dimension t(npt,nz), h(npt,nz), nzi(npt)

      do i = 1, npt
         do k = 1, nzi(i)
            t(i,k) = t(i,k)/h(i,k)
         enddo
      enddo

      return
      end

c     ------------------------------------------------------------------
      subroutine capt(npt,nz,nzi,t,h)
c     ------------------------------------------------------------------
c     form the heat content, ht, from the temperature.
c
      dimension t(npt,nz),h(npt,nz),nzi(npt)
c
      do i = 1, npt
         do k = 1, nzi(i)
            t(i,k) = t(i,k)*h(i,k)
         enddo
      enddo

      return
c     end of capt.
      end


      subroutine fixed_dep (npt,nzi_b,h,fu,fv,tfu,tfv,rhsx,rhsy,crhsx,crhsy)
c-----------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension h(npt,1),fu(npt,1),fv(npt,1),tfu(1),tfv(1),nzi_b(npt)
#ifdef dump_all
      dimension rhsx(npt,1), rhsy(npt,1)
      dimension crhsx(npt,1), crhsy(npt,1)
#endif

      do i = 1, npt
         do k = 1, nzi_b(i)
            hk = h(i,k)
#ifdef dump_all
            rhsx(i,k) = fu(i,k)
            rhsy(i,k) = fv(i,k)
#endif
            fu(i,k) = fu(i,k) - hk* tfu(i)
            fv(i,k) = fv(i,k) - hk* tfv(i)
#ifdef dump_all
            crhsx(i,k) = fu(i,k)
            crhsy(i,k) = fv(i,k)
#endif
         enddo
      enddo
      return
      end

c     ------------------------------------------------------------------
      subroutine tupdat(npt,nz,nzi,binv,abinv,t,ft)
c     ------------------------------------------------------------------
c     update temperature fields as was done for u, v, h in updat1.
c
      implicit real(a-h,o-z),integer(i-n)
      dimension t(npt,nz),ft(npt,nz),nzi(npt)
c
      do i = 1, npt
         do k = 1, nzi(i)
            t(i,k)  = t(i,k)  + binv*ft(i,k)
            ft(i,k) = abinv*ft(i,k)
         enddo
      enddo
      return
c     end of tupdat.
      end


c     ------------------------------------------------------------------
      subroutine zerodt(dt,nlo,lo,nb,lb,tp)
c     ------------------------------------------------------------------
c     set flux of t zero at the boundaries.
c     dt/dx = 0 at the x-sidewall boundaries.
c     dt/dy = 0 at the y-sidewall boundaries.
c
      dimension dt(1),lo(1),tp(1),lb(1)
c
      if (nlo.gt.0) then
c       first save the open boundary dt values.
         do i=1,nlo
            tp(i) = dt(lo(i))
         enddo
      endif
c
c     now zero dt at all x or y-boundaries.
      do i=1,nb
         dt(lb(i)) = 0.
      enddo
c
      if (nlo.gt.0) then
c       replace dt values at open boundaries.
         do i=1,nlo
            dt(lo(i)) = tp(i)
         enddo
      endif
c
      return
c     end of zerodt.
      end

c     ------------------------------------------------------------------
      subroutine bcset(mbc,lxxk,lyyk,npt,u,v,nzi,nzi_b)
c     ------------------------------------------------------------------
c     impose the u, v boundary conditions according to mbc.
c
c     mbc = (input) type of boundary condition:
c         = 1; u(xb)=v(yb)=u(yb)    = v(xb)    = 0; no slip everywhere.
c         = 2; u(xb)=v(yb)                     = 0; no normal flow.
c         = 3; u(xb)=v(yb)=du(yb)/dy= v(xb)    = 0; no slip at eastern
c              and western side walls; free slip along northern and
c              southern boundaries/steps, v=du/dy=0.
c         = 4; u(xb)=v(yb)=u(yb)    = dv(xb)/dx= 0; no slip at northern
c              and southern; free slip along eastern and western
c              boundaries/steps, u=dv/dy=0.
c
c     lxx = (input) nbx x-boundary plus ncs corner indices for a 
c           regular or compressed x-sort.
c     lyy = (input) nby y-boundary plus ncs corner indices for a
c           regular or compressed x-sort.
c     npt = (input) number of field points/layer.
c     u,v = (input) fields.
c         = (output) fields with boundary conditions imposed.
c
      implicit real(a-h,o-z),integer(i-n)

      include 'comm_para.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc

      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      dimension lxxk(MXBDY,nz), lyyk(MXBDY,nz)

      dimension u(npt,nz),v(npt,nz),nzi(npt),nzi_b(npt)
c
c     normal components are always zero at boundaries, u(xb)=v(yb)=0.
c     similarly, so is the along boundary derivative
c       du(xb)/dy = dv(yb)/dx = 0.
c
c     the ncs corner points are part of the u/v-boundaries depending
c     on mbc.
c     mbc = 1;  yes for u and v;     du(yb)/dx = dv(xb)/dy = 0.
c         = 2;  no for u and v.
c         = 3;  no for u, yes for v; dv(xb)/dy = 0.
c         = 4;  yes for u, no for v; du(yb)/dx = 0.
c
      do k = 1, nz
         do i = 1, nbxk(k)
            u(lxxk(i,k),k) = 0.
         enddo
         do i = 1, nbyk(k)
            v(lyyk(i,k),k) = 0.
         enddo
      enddo

      do i = 1, npt
         do k = nzi_b(i)+1,nzi(i)
            u(i,k) = 0.
            v(i,k) = 0.
         enddo
      enddo

      if(mbc.eq.1 .or. mbc.eq.4) then
         do 30 k=1,nz
         do 30 i=1,nbyk(k)+ncsk(k)
   30    u(lyyk(i,k),k) = 0.
      endif
c
      if(mbc.eq.1 .or. mbc.eq.3) then
         do 40 k=1,nz
         do 40 i=1,nbxk(k)+ncsk(k)
   40    v(lxxk(i,k),k) = 0.
      endif
      return
c     end of bcset.
      end


c     --------------------------------------------------------
      logical function non_stable (iout, npt, nxp, nz, iox, t, u, v)
c     --------------------------------------------------------
c     check to see that t  or velocities are not bizarre
c     h      = (input) layer thickness field.
      implicit real(a-h,o-z),integer(i-n)
      dimension t(npt,1), iox(1), u(npt,1), v(npt,1)
c
      non_stable = .false.
      icheck = 0
      do i = 1, npt
         if (t(i,2) .lt. -10..or.t(i,2).gt.50.or.
     *       u(i,1)**2+v(i,1)**2.gt.400.) icheck = icheck + 1
      enddo
      
      non_stable = (icheck .ne. 0)
      if (non_stable) then
         write (iout, *) 'Number of illegal points =', icheck 
         do i = 1, npt
            if (t(i,2) .lt. -10..or.t(i,2).gt.50) then
               jj = 1 + (iox(i)-1)/nxp
               ii = iox(i) - (jj-1)*nxp
               write (iout, 11) i, ii, jj, t(i,2)
            endif
            if (u(i,1)**2 + v(i,1)**2 .gt. 400.) then
               jj = 1 + (iox(i)-1)/nxp
               ii = iox(i) - (jj-1)*nxp
               write (iout, 12) i, ii, jj
            endif
         enddo
      endif
   11 format ('t(k=',i4,',2)[i=',i3,',j=',i3,'] =', g10.3)
   12 format ('i,ii,jj=',3i8,'  velocity is greater than 20 m/s')

      return
      end

      subroutine h_updat(npt,nsig,binv,abinv,h,fh)
c------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension h(npt,1),fh(npt,1)
      include 'comm_new.h'
 
      do k = 1, nsig
         do i = 1, npt
            h(i,k)  = h(i,k) + binv*fh(i,k)
            fh(i,k) = abinv*fh(i,k)
         enddo
      enddo
      
      return
      end

c     ------------------------------------------------------------------
      subroutine btpgf(npt,nzi_b,h,temp,dens,fu,fv,emx,emy,lxxk,lyyk,lxyk,lyxk,
     *                snxk,snyk,isyk,isk,lok,tp,tq,tr,lpbcwk,lpbcek,zfu,zfv,
     *                pgfx,pgfy)
c     ------------------------------------------------------------------
c     subroutine that calculates the pressure gradient terms in the
c     momentum equation
c
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'

      dimension h(npt,nz),temp(npt,nz), fu(npt,nz),fv(npt,nz),
     *     emx(1),emy(1),tp(npt,4),tq(npt,4),tr(npt,1),
     *   dens(npt,nz),tmp(npt,nz),zfu(npt),zfv(npt),
     *   pgfx(npt,nz),pgfy(npt,nz)
      dimension lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     *     snxk(MAXNB,nz),snyk(MAXNB,nz),isyk(npt,nz),isk(npt,nz),nzi_b(npt),
     *     lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz)
      pointer (p_tmp, tmp)
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)

c-new     temp array should contain temp, not heat content!!!
c-new     dens array should contain dens, not mass!!!
c
      if (use_salt) then
c .......................................case of density from EOS:
c b = (grav/(1000+sigma0)) * (sigma0 - sigma(k))
c
         coef = -GRAVTY / (1000. + SITUD_BOT)
         bottom = SITUD_BOT
         p_tmp = loc(dens)
      else
c .....................case of linear (in T) density and buoyancy:         
c b = alph * grav * (t(k) - t_bot)

         coef = TALPHA * GRAVTY
         bottom = TEMP_BOT
         p_tmp = loc(temp)
      endif

      do i = 1, npt
         dh = h(i,1)/2.
         tp(i,1) = dh*tmp(i,1)
         tp(i,2) = dh  
         tp(i,4) = dh  
         tq(i,3) = coef * emx(i)
         tq(i,4) = coef * emy(i)
      enddo

      do k = 1, nz
         npk = nptk(k)
         nxk = nbxk(k)
         nyk = nbyk(k)
         nck = ncsk(k)
         npbk = npbck(k)
         nok = nlok(k)
         call dfdxk(tp,tq,npt,npk,0,nxk,nyk,nck,lxxk(1,k),lyxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k))
         call dfdxk(tp(1,2),tq(1,2),npt,npk,0,nxk,nyk,nck,lxxk(1,k),lyxk(1,k),
     *       snxk(1,k),npbk,lpbcwk(1,k),lpbcek(1,k),isk(1,k))
         call zerodt(tq(1,1),nok,lok(1,k),nxk,lxxk(1,k),tp(1,3))
         call zerodt(tq(1,2),nok,lok(1,k),nxk,lxxk(1,k),tp(1,3))

         do j = 1, npk
            i = isk(j,k)
            abc = tq(i,3) * (tq(i,1) - tmp(i,k) * tq(i,2))
            pgfx(i,k) = abc
            fu(i,k) = fu(i,k) + h(i,k)*abc
         enddo

         call dfdyk(tp(1,1),tq(1,1),npt,npk,0,nyk,nxk,nck,lyyk(1,k),lxyk(1,k),
     *        snyk(1,k),isyk(1,k))
         call dfdyk(tp(1,2),tq(1,2),npt,npk,0,nyk,nxk,nck,lyyk(1,k),lxyk(1,k),
     *        snyk(1,k),isyk(1,k))
         call zerodt(tq(1,1),nok,lok(1,k),nyk,lyxk(1,k),tp(1,3))
         call zerodt(tq(1,2),nok,lok(1,k),nyk,lyxk(1,k),tp(1,3))

         do j = 1, npk
            i = isk(j,k)
            abc = tq(i,4) *  (tq(i,1) - tmp(i,k) * tq(i,2) )
            pgfy(i,k) = abc
            fv(i,k) = fv(i,k) + h(i,k)*abc
         enddo
         
         if (k .lt. nz) then
            do j = 1, npk
               i = isk(j,k)
               dh      = h(i,k) - tp(i,4)
               tp(i,1) = tp(i,1) + dh*(tmp(i,k) + tmp(i,k+1))
               tp(i,2) = tp(i,2) + 2.*dh
               tp(i,4) = dh
            enddo
         endif
      enddo

      do i = 1, npt
         do k = 1, nzi_b(i)
               zfu(i) = zfu(i) + h(i,k)*pgfx(i,k)
               zfv(i) = zfv(i) + h(i,k)*pgfy(i,k)
         enddo
      enddo

      return
      end      

dyn_subs.f/     849648670   1572  1572  100444  18562     `
c$Source: /usr/our/senya/work/model/MC_PG/senq/RCS/dyn_subs.f,v $
c$Author: senya $
c$Revision: 0.4 $
c$Date: 94/01/24 11:04:57 $
c$State: Exp $
c     ------------------------------------------------------------------
      subroutine aarea(npt,nz,lxxk,lyxk,emx,emy,area,basin,isk,nzi,h,sax,say,saz)
c     ------------------------------------------------------------------
c     compute the stretched grid area factors for computing integrals
c     over the grid in the stretched coordinate system.
c       dx*dy = (d(x)/dpsi1(x) * d(y)/dpsi2(y)) * dpsi1 * dpsi2
c     for transformation (stretching) functions dpsi1 and dpsi2.
c
c     from common block grid:
c     nxp,nyp = (input) grid dimensions in the x and y directions.
c     nxyc    = (input) number of ocean grid points.
c     land    = (input) land storage flag.
c     nbx,nby = (input) number of x and y boundaries.
c     ncs     = (input) number of interior corner boundary grid points.
c
c     lxxk   = (input) nbx indices of the x-boundaries for an x
c                     (compressed or regular) sort.
c     lyxk   = (input) nby indices of the y-boundaries for an x
c                     (compressed or regular) sort.
c     emx   = (input) factor for x-differencing = d(psi1)/d(x)*(1./delx)
c     emy   = (input) factor for y-differencing = d(psi2)/d(y)*(1./dely)
c     isk   = (input) index from compressed k to compressed k=1 points
c     area  = (output) .5*dx*dy.
c     basin = (output) .5*(total basin area).
c     sax   = (output) surface area of cell(i,k) at west,east
c     say   = (output) surface area of cell(i,k) at south,north
c     saz   = (output) surface area of cell(i,k) at top,bottom
c
      include 'comm_para.h'
      implicit real(a-h,o-z),integer(i-n)
      dimension lxxk(MXBDY,nz),lyxk(MXBDY,nz)
      dimension emx(1),emy(1),area(npt,nz),basin(nz)
      dimension nzi(npt),h(npt,nz),sax(npt,nz,2),say(npt,nz,2),saz(npt,nz,2)
      dimension isk(npt,nz)
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
c
      r2 = 0.5

      do k = 1, nz
c
c     find 1/2 the area (1/2 factor used on energy calculations)
c     as if all grid squares were completely ocean.
c
         do i=1,nptk(k)
            j = isk(i,k)
            area(j,k) = r2/(emx(j)*emy(j))
         enddo
c   
c     correct the x-boundary grid point areas.
c
         do  i=1,nbxk(k)
            area(lxxk(i,k),k) = area(lxxk(i,k),k)*.5
         enddo
c
c     correct the y-boundary grid point areas.
c
         do i=1,nbyk(k)
            area(lyxk(i,k),k) = area(lyxk(i,k),k)*.5
         enddo
c
c     correct the interior corner point areas.
c
         do i=nbxk(k)+1,nbxk(k)+ncsk(k)
            area(lxxk(i,k),k) = area(lxxk(i,k),k)*.75
         enddo
         
         basin(k) = 0.
         do i=1,nptk(k)
            j = isk(i,k)
            basin(k) = basin(k) + area(j,k)
         enddo

      enddo

c      do k = 1, nz
c         do i = 1,npt
c            sax(i,k,1) = 1.
c            sax(i,k,2) = 1.
c            say(i,k,1) = 1.
c            say(i,k,2) = 1.
c            saz(i,k,1) = 1.
c            saz(i,k,2) = 1.
c         enddo
c         do i = 2, nptk(k)-1
c            j = isk(i,k)
c            sax(i,k,1) = (emx(j)/emx(j-1) + 1.)/2.
c            sax(i,k,2) = (emx(j)/emx(j+1) + 1.)/2.
c         enddo
c         do i = 1, npbck(k)
c            i2 = lpbce(i)
c            i1 = lpbcw(i)
c            sax(i1,k,1) = (emx(i1)/emx(j-1) + 1.)/2.
c            sax(i2,k,2) = (emx(j)/emx(j+1) + 1.)/2.
c            sax(i1,k,1) = sax(i2,k,2)
c            sax(i2,k,2) = sax(i2,k,1)
c         enddo
c         do i = 1, nbxk(k)
c            i1 = lxx(i,1)
c            sax(i1,k,1) = 1.
c            sax(i1,k,2) = 1.
c         enddo
c      enddo
         
      return
c     end of aarea.
      end
c
c     ------------------------------------------------------------------
      subroutine scaset(iox,x,y,xp,yp,f,emx,emy,emxy,emx2,emy2,tp)
c     ------------------------------------------------------------------
c     subroutine called by wdrivn that computes the coordinates of the
c     grid points and length scale variables with and without stretching,
c     e.g. arrays emx, emy, emxy, and f.
c
c     from common block grid:
c
c     nxp,nyp = (input) grid dimensions in the x and y directions.
c     nxyc    = (input) number of ocean grid points.
c
c     from common block coords:
c
c     alon,blon = (input) min,max x grid coordinates in degrees.
c     alat,blat = (input) min,max y grid coordinates in degrees.
c     rlat    = (input) reference latitude for beta plane and f plane. 
c     mgrid   = (input) determines coordinate system (stretching
c               determined by nsx, nsy).
c             = 1; beta plane with delx = (blon-alon)/((nxp-1)*rearth).
c             = 2; spherical coords with
c                    delx = (blon-alon)((nxp-1)*rearth*cos(y(i))
c                  (for spherical coords, delx is a function of the
c                  convergence of meridians away from the equator.)
c             = 3; f-plane with
c                    delx = (blon-alon)((nxp-1)*rearth). 
c     nsx,nsy = (input) see routine stretch for a description.
c             = 0; no stretching.
c
c     iox   = (input) nxyc indices of the x-sorted ocean grid points.
c     x,y   = (output) nxp x and nyp y grid point coordinates (degrees).
c     xp    = (output) nxp derivatives of the x-transformation function
c                      if coordinate stretching is used (see gridxy).
c     yp    = (output) nyp derivatives of the y-transformation function
c                      if coordniate stretching is used (see gridxy).
c     emx   = (output) factor for x-differencing= d(psi1)/d(x)*(1./delx)
c     emy   = (output) factor for y-differencing= d(psi2)/d(y)*(1./dely)
c     f     = (output) coriolis factor for routine dhoriz.
c     modified to account for the Pole's shift (Senya Basin, 1996)
c
      implicit real(a-h,o-z),integer(i-n)
      parameter (maxxs=50)
      parameter (REARTH = 6378000., 
     *           DTOSEC = 86400., 
     *           RAD    = 3.14159265/180.,
     *           TOMEGA = 4.*3.14159265/DTOSEC)
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /coords/ alat,blat,rlat,alon,blon,nsx,nsy,mgrid,z_begin,nsig,nystrch
      common/strech/xs(maxxs),alpha(maxxs),beta(maxxs)
      common /new_geom/  ixs_type,iys_type,ipole,pole_alp,pole_bet,pole_gam
c
c     for spherical coords (mgrid=2), add array emxy to dimension
c     and subroutine calls.
c
      dimension iox(1),x(1),y(1),xp(1),yp(1),emx(1),emy(1),f(1),emxy(1)
     *          ,emx2(1), emy2(1), tp(1)

c
c     compute the grid point x and y coordinates in degrees.
c
      call gridxy(nxp,nyp,alon,blon,alat,blat,nsx,nsy,nystrch,xs,alpha,beta,
     +            x,y,xp,yp,tp,tp(nxp+1))

      delx = (blon-alon)*RAD/float(nxp-1)
      dely = (blat-alat)*RAD/float(nyp-1)
c
c     convert to inverse delta x and delta y scale in m.
c
      xfac = 1./(delx*REARTH)
      yfac = 1./(dely*REARTH)

      rlat = 0.5*(alat + blat)

      if ( (mgrid.eq.1) .or. (mgrid.eq.3) ) then
c........beta plane or f plane.
         fz    = sin(rlat*rad)
         betap = cos(rlat*rad)
         cosy  = 1./betap
c.............................for on f-plane.
         if (mgrid .eq.3 ) betap = 0.
         
         do k = 1, nxyc
            j = (iox(k)-1)/nxp + 1
            i = iox(k) - (j-1)*nxp
            f(k) = (fz + betap*RAD*(y(j)-rlat))*TOMEGA
            emx(k) = xfac*xp(i)*cosy
            emy(k) = yfac*yp(j)
         enddo
      elseif (mgrid .eq. 2) then
c.......................for spherical coordinates.
         do k = 1, nxyc
c           convert the x-sort index to i,j.
            j = (iox(k)-1)/nxp + 1
            i = iox(k) - (j-1)*nxp
            yrad = y(j)*RAD
            fj = sin(yrad)*TOMEGA
            cosy = 1./cos(yrad)
            xyfac = -tan(yrad)/REARTH
            cos2  = cosy*cosy
            
            f(k)    = fj
            emx(k)  = xfac*xp(i)*cosy
            emy(k)  = yfac*yp(j)
            emxy(k) = xyfac
            
            emx2(k) = xfac*xfac*tp(i)*cos2
            emy2(k) = yfac*yfac*tp(nxp+j)
         enddo
      endif

      if (ipole .eq. 1) then
c...........................re-compute Coriolis for a rotated Pole:
         do k = 1, nxyc
            j = (iox(k)-1)/nxp + 1
            i = iox(k) - (j-1)*nxp

            f(k)    = TOMEGA * rot_fcr2g(x(i), y(j))
         enddo
      endif

      return
c     end of scaset.
      end
c
c     ------------------------------------------------------------------
      subroutine stretch(nx,xmin,xmax,ns,xs,alpha,beta,x,xp,xpp)
c     ------------------------------------------------------------------
c     compute grid point locations for a stretched coordinate system.
c
c     nx        = (input) # of grid points in a coordinate direction.
c     xmin,xmax = (input) coordinate range of the nx grid points.
c     ns        = (input) # of atan's defining the transformation from
c                 the stretched coordinates to the regular coordinates.
c     xs        = (input) ns locations of the atan's.
c     alpha     = (input) ns scaling parameters for the atan's in degrees.
c     beta      = (input) ns scaling parameters for the atan's in degrees.
c     x         = (output) nx stretched grid point locations.
c     xp        = (output) nx derivatives of the transformation function
c                          d(psi(x))/d(x).
c     xpp       = (output) nx second derivatives of the transformation 
c                          function: d^2(psi(x))/d(x)^2. (by Senya Basin)
c        
c     the transformation from the stretched coordinates x to the regular
c     coordinates xx is
c      xx = psi(x) = a + b*(x + sum of alpha(i)*atan((x-xs(i))/beta(i))
c                     + c*x**2
c
c     the extra degree of freedom provided by c*x**2 is used to locate
c     a grid point right at the equator.  note the definition of psi
c     differs slightly from cane & gent & ncar code.  alpha can be
c     modified to reproduce ncar stretching.
c
c     for nx equally spaced values of xx from xmin to xmax, this routine
c     finds the corresponding values of the coord x.  the stretched grid
c     point spacing will be the smallest near x=xs(i).  increasing the
c     parameter alpha(i) increases the # of stretched grid points in the
c     vicinity of xs(i).  increasing beta(i) widens the region around
c     xs(i) in which grid points are concentrated.  if xmin*xmax.ge.0.
c     (basin does not span the equator) then the parameter c is set to
c     0., and a and b are chosen by this routine to force the ends of
c     the computational and physical grids to be the same:
c     psi(xmin)=xmin, psi(xmax)=xmax.  if xmin*xmax .lt. 0., then the
c     parameters a, b, and c are chosen to force psi(xmin)=xmin,
c     psi(0.)=0., and psi(xmax)=xmax.
c
c     nbegns : the function psi(x) is initially computed at nbegns 
c              equally spaced points between xmin and xmax to provide 
c              a table of starting values for the iterative solution.
c
c     maxit  = the maximum allowed number of iterations.
c
c     eps    = the iterative solution for x is continued until 
c              abs( (x_this_iter. - x_last_iter.)/x_last_iter. ).le.eps
c
      implicit real(a-h,o-z),integer(i-n)
      parameter (nbegns=100, maxit=1000, eps=1.e-6)
      dimension xs(1),alpha(1),beta(1),x(1),xp(1),xpp(1)
c
c     solve for a, b, (and c) by construing the physical and
c     computational grids at the end points (and equator).
c     
      if(xmin*xmax.ge.0.) then
c
c        get the scaling factors a and b, which will force 
c        psi(xmin)=xmin and psi(xmax)=xmax.
c
c        evaluate psi at the end points as if a=0 and b=1.
c
         ymin = psi(xmin,0.,1.,0.,ns,xs,alpha,beta)
         ymax = psi(xmax,0.,1.,0.,ns,xs,alpha,beta)
c        solving for two equations and two unknowns yields:
         a = (xmin*ymax-ymin*xmax)/(ymax-ymin)
         b = (xmax-xmin)/(ymax-ymin)
         c = 0.
      else
c
c        for a basin that includes the equator.
c
c        get the scaling factors a,b and c, which will force 
c        psi(xmin)=xmin, psi(xmax)=xmax, and psi(0.) = 0.
c
c        evaluate psi at the end points and equator as if
c        a=c=0 and b=1.
c
         ymin = psi(xmin,0.,1.,0.,ns,xs,alpha,beta)
         ymax = psi(xmax,0.,1.,0.,ns,xs,alpha,beta)
         y0   = psi(  0.,0.,1.,0.,ns,xs,alpha,beta)
         x1 = xmin*xmin
         x2 = xmax*xmax
c        solving three equations for three unknowns:
         b = (xmin*x2-xmax*x1)/(x2*(ymin-y0)-x1*(ymax-y0))
         c = (xmin - b*(ymin-y0))/x1
         a = -b*y0
      endif
c
      kstart = 1
      delx = (xmax-xmin)/float(nbegns-1)
      psi1 = psi(xmin,a,b,c,ns,xs,alpha,beta)
c
c     loop over nx values of xx evenly spaced from xmin to xmax 
c     and find the corresponding values of x such that xx = psi(x).
c
      dx = (xmax-xmin)/float(nx-1)
      do 50 i = 1,nx
         xx = xmin + (i-1)*dx
c
c     use Newton's method to find x for f(x) = psi(x)-xx = 0:
c       f(x+delx) ~= f(x) + f'(x)*delx + f"(x)/2*delx**2 + ...
c       for f(x+delx)=0, delx = -f(x)/f'(x)
c       xj1 = xj - f(xj))/fp(xj);   fp(x) = dpsi = d(psi(x))/d(x)
c
c     first find psi1 and psi2 straddling xy such that
c     psi1.le.xx .and. xx.le.psi2 and iterate on x from there.
c
   20    psi2 = psi(xmin+kstart*delx,a,b,c,ns,xs,alpha,beta)
         if (psi2 .ge. xx) goto 30
         if (kstart .lt. nbegns-1) then
c     if not, increase x.
            kstart = kstart + 1
            psi1 = psi2
            goto 20
         endif
c
c     interpolate between two values of psi to get a starting xj.
c
   30    xj1 = xmin + (kstart-1)*delx + (xx-psi1)*delx/(psi2-psi1)
c
c     loop until abs((xj1-xj)/xj).le.eps or iter.eq.maxit
c
         iter = 0
   40    xj = xj1
         f  =  psi(xj,a,b,c,ns,xs,alpha,beta) - xx
         fp = dpsi(xj,a,b,c,ns,xs,alpha,beta)       
         xj1 = xj - f/fp
         iter = iter + 1
         if(xj .ne. 0.) then
            if((abs((xj1-xj)/xj).gt.eps).and.(iter.lt.maxit)) goto 40
         else
            if(abs(xj1) .gt. eps) goto 40
         endif

c     store x location.
         x(i)=xj
c     store psi derivative: xp = d(psi)/d(x)
         xp(i) = fp
c     xpp = d^2(psi)/dx^2
         xpp(i) = d2psi(xj,a,b,c,ns,xs,alpha,beta)

   50 continue
c
ccc   fix the ends:
      x(1)  = xmin
      x(nx) = xmax
ccc
      return
c     end of stretch.
      end

c     ------------------------------------------------------------------
      real function d2psi(x,a,b,c,ns,xs,alpha,beta)
c     ------------------------------------------------------------------
c     Second derivative of the stretching function. (Senya Basin)
c     d2x = b * sum { -alpha/beta^2 * (2e/(1+e^2)^2 } + 2*c; e = (x-xs)/beta

      implicit real(a-h,o-z),integer(i-n)
      dimension xs(1),alpha(1),beta(1)
c
      sum  = 0.
      do i = 1, ns
         binv = 1./beta(i)
         e = binv*(x - xs(i))
         e2 = 1. + e*e
         sum = sum + alpha(i)*binv*binv*(e + e)/(e2 * e2)
      enddo

      d2psi = -b*sum + 2.*c
      return
c     end of function d2psi.
      end


c     ------------------------------------------------------------------
      real function dpsi(x,a,b,c,ns,xs,alpha,beta)
c     ------------------------------------------------------------------
c     derivative of the stretching function.
c
      dimension xs(1),alpha(1),beta(1)
c
      sum  = 0.
      do 10 i=1,ns
      e = (x - xs(i))/beta(i)
   10 sum = sum + (alpha(i)/beta(i)) * 1./(1.+ e*e)
      dpsi = b*(1. + sum) + 2.*c*x
      return
c     end of function dpsi.
      end
c
c     ------------------------------------------------------------------
      real function psi(x,a,b,c,ns,xs,alpha,beta)
c     ------------------------------------------------------------------
c     coordinate stretching function.
c
      dimension xs(1),alpha(1),beta(1)
c
      sum  = x
      do 10 i=1,ns
   10 sum = sum + alpha(i)*atan((x-xs(i))/beta(i))
      psi = a + b*sum + c*x*x
      return
c     end of function psi.
      end

c 
      subroutine wspace(parm,need)
c     ------------------------------------------------------------------
c     write an error message about the required array space and exit.
c
c     parm = (input) six-character name of the dimension parameter.
c     need = (input) needed value for the parameter parm, or zero.
c          = 0, then the needed value is not included in the message.
c
      implicit real(a-h,o-z),integer(i-n)
      character*6 parm
      character*72 msg
      if(need.ne.0) then
         write(msg,1) parm,need
    1    format('insufficient space, increase dimension parameter ',
     +          a6,' to ',i6,'$')
      else
         write(msg,2) parm
    2    format('insufficient space, increase dimension parameter ',a6,
     +          '$')
      endif
      call perror1(msg,1)
      return
c     end of wspace.
      end

c     ------------------------------------------------------------------
      subroutine perror1(msg,istop)
c     ------------------------------------------------------------------
c     print the character string msg and exit the program if istop.ne.0
c
c     msg    = (input) character string containing a message to be
c              printed.
c     istop  = (input) stop flag
c            = 0, continue execution
c            = otherwise, exit the program
c     ioerr  = (input) unit number for error messages.
c
      character*(*) msg
      character*72 err
      common/errors/ioerr,nstep
c
c     check if ioerr is reasonable.  if not, write to unit 6.
c
      if(ioerr.ge.1 .and. ioerr.le.99) then
         io = ioerr
      else
         io = 6
      endif
c
      if(nstep .gt. 0) then
         if(istop.eq.0) then
            write(io,1) nstep
    1       format(1x,'warning on step ',i10)
         else
            write(io,2) nstep
    2       format(1x,'error exit on step ',i10)
         endif
      endif
      if(len(msg) .gt. 0) then
         l = len(msg)
         iend = 0
         do 10 i=1,72
         if(msg(i:i) .eq. '$') iend = 1
         if(i .gt. l  .or.  iend .eq. 1) then
            err(i:i) = ' '
         else
            err(i:i) = msg(i:i)
         endif
   10    continue
         write(io,11) err
   11    format(1x,a72)
      endif
c
c     close all open output data files and stop execution.
c
      if(istop.ne.0) then
         call cstop
         stop
      endif
      return
c     end of perror.
      end
c

dyn_tios.f/     847479278   1572  1572  100666  20760     `
#define c_str(s) ('s\0')
c----------------------------------------------------------------------
      subroutine init_data_out (tfile,dfile,nx,ny,npt,xx,yy,en)
c----------------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_pbl.h'
      include 'comm_diff.h'
      include 'comm_tracer.h'

      character*(*) tfile, dfile 
      real en(1), xx(1), yy(1)
      real zz(100)
      integer tios_idvar
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /tios_id/ iddq, idri, idenm, ifoh ,idmosf, idtm, idep,
     &          idtrtflx,idtrtcp,idtrtflx1,idtrtflx2,idtrtflx3,
     &          idtrtevp,idtrtprc,idtrtrlh
 
      save zz

      call tios_init (tfile, dfile)

      do i = 1, nz+1
         zz(i) = real(i)
      enddo

      call tios_grid (id_g0, nxp, nyp,   1,  xx, yy, zz)
      call tios_grid (id_g1, nxp, nyp,  nz,  xx, yy, zz)
      call tios_grid (id_g2, npten, 1, nz+1, zz, zz, zz)
      call tios_grid (id_g3, nxp, nyp, nz-1, xx, yy, zz)
      call tios_grid (id_g4, 1, nyp, nz+1, xx, yy, zz)

      call tios_map  (imap, nxp*nyp, nxyc, iox)

      call tios_var (t,  c_str(TEMP), id_g1, imap) 
      call tios_var (u,  c_str(U_VEL), id_g1, imap) 
      call tios_var (v,  c_str(V_VEL), id_g1, imap) 
      call tios_var (w,  c_str(W_VEL), id_g1, imap) 
      call tios_var (fhd,  c_str(DIV), id_g1, imap) 

      call tios_var (ucs,  c_str(US_C), id_g1, imap) 
      call tios_var (vcs,  c_str(VS_C), id_g1, imap) 
      call tios_var (ws,  c_str(WS_VEL), id_g1, imap) 
      if (use_salt) then
         call tios_var (sal, c_str(SALT), id_g1, imap) 
         call tios_var (dens,c_str(DENS), id_g1, imap) 
         call tios_var (pdens,c_str(PDENS), id_g1, imap) 
      endif

      call tios_var (pgfx, c_str(PGF_X), id_g1, imap)
#ifdef dump_all
      call tios_var (rhsx,  c_str(RHS_X), id_g1, imap) 
      call tios_var (corx,  c_str(COR_X), id_g1, imap) 
      call tios_var (xnl,  c_str(NONLIN_X), id_g1, imap) 
      call tios_var (vertx,  c_str(VERT_X), id_g1, imap) 
      call tios_var (crhsx,  c_str(CRHS_X), id_g1, imap) 
#endif

      call tios_var (pgfy, c_str(PGF_Y), id_g1, imap)
#ifdef dump_all
      call tios_var (rhsy,  c_str(RHS_Y), id_g1, imap) 
      call tios_var (cory,  c_str(COR_Y), id_g1, imap) 
      call tios_var (ynl,  c_str(NONLIN_Y), id_g1, imap) 
      call tios_var (verty,  c_str(VERT_Y), id_g1, imap) 
      call tios_var (crhsy,  c_str(CRHS_Y), id_g1, imap) 
#endif

      idenm = tios_idvar (c_str(D_MEAN), id_g1, imap) 
      call tios_var (tm,  c_str(T_MEAN), id_g1, imap) 
      call tios_var (um,  c_str(U_MEAN), id_g1, imap) 
      call tios_var (vm,  c_str(V_MEAN), id_g1, imap) 
      call tios_var (wm,  c_str(W_MEAN), id_g1, imap) 
      if (use_salt) then
         call tios_var (salm,  c_str(S_MEAN),    id_g1, imap) 
         call tios_var (densm, c_str(DENS_MEAN), id_g1, imap) 
      endif

      iddq = tios_idvar(c_str(HFLX), id_g0, imap)
      call tios_var(solr(npt3), c_str(SOLAR_qisw),    id_g0, imap)
      call tios_var(qb(npt2), c_str(LATENT_rlh),   id_g0, imap)
      call tios_var(qb(npt3), c_str(SENSIBLE_sh), id_g0, imap)
      call tios_var(qb(npt4), c_str(LONGWAVE_qlw), id_g0, imap)
      call tios_var(qb(npt4+nxyc), c_str(DEFICIT), id_g0, imap)
      call tios_var(cld(npt3), c_str(CLDFR),  id_g0, imap) 

      call tios_var(wnd, c_str(WNSP_wspd), id_g0, imap) 
      call tios_var(wnd(npt2), c_str(UWND_u), id_g0, imap) 
      call tios_var(wnd(npt3), c_str(VWND_v), id_g0, imap) 
      call tios_var(sst(npt3), c_str(SST),  id_g0, imap)
      if (use_salt) then
         idep = tios_idvar(c_str(SFLX),  id_g0, imap) 
         call tios_var(sss(npt3), c_str(SSS), id_g0, imap)
      endif

      if (initq .eq. 8.or.use_ice) then
         call tios_var(amhum,     c_str(PBLHUM_qa), id_g0, 0)
         call tios_var(amth,      c_str(PBLTEM_th), id_g0, 0)
         call tios_var(ahum(1,3), c_str(AIRHUM_q),  id_g0, 0)
         call tios_var(atem(1,3), c_str(AIRTEM_t),  id_g0, 0)
      endif
      if (use_ice) then
         call tios_var(cice,   c_str(CICE), id_g0, imap)
         call tios_var(hice,   c_str(HICE), id_g0, imap)
         call tios_var(thice,  c_str(THICE), id_g0, imap)

         call tios_var(qios,   c_str(QIOS), id_g0, imap)
         call tios_var(brne,   c_str(BRNE), id_g0, imap)
         call tios_var(qb(npt1),    c_str(QSW), id_g0, imap)
         call tios_var(prcp(npt3),    c_str(PPI), id_g0, imap)
         call tios_var(pp,     c_str(PP), id_g0, imap)

         call tios_var(tsnw,   c_str(TSNW), id_g0, 0)
         call tios_var(rh,     c_str(RH), id_g0, 0)
         call tios_var(rlhi,   c_str(RLHI), id_g0, 0)
         call tios_var(shi,    c_str(SHI), id_g0, 0)
         call tios_var(qlwi,   c_str(QLWI), id_g0, 0)
         call tios_var(qswi,   c_str(QSWI), id_g0, 0)
      endif

      call tios_var (convn, c_str(CONVN), id_g1, imap) 

      call tios_var (en, c_str(ENRG),  id_g2, 0)
      call tios_var (w((nz-1)*nxyc+1) , c_str(SEALEV), id_g0, imap) 
      idri = tios_idvar (c_str(RI),     id_g3, imap)

      ifoh = idvar_tios (c_str(FOH), id_g0, imap)
      call tios_var (dept, c_str(TOTAL_DEPTH), id_g0, imap)
      call tios_var (relax, c_str(RELAX), id_g0, imap)
      call tios_var (sponge, c_str(SPONGE), id_g0, imap)
      if (ibaro .ne. 0) then
         call tios_var (psi, c_str(PSI), id_g0, imap)
         call tios_var (ubar, c_str(U_BAR), id_g0, imap)
         call tios_var (vbar, c_str(V_BAR), id_g0, imap)
      endif
      call tios_var(taux, c_str(TAUX), id_g0, imap) 
      call tios_var(tauy, c_str(TAUY), id_g0, imap) 


      idtm = idvar_tios (c_str(DEPTH), id_g1, imap)

      idmosf = tios_idvar (c_str(W_MOSF),     id_g4, 0)
      call tios_var (psiw, c_str(MOSF), id_g4, 0)

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      if (use_trac) then
         do i=1,ntrac
            it = npt*nz*(i-1) + 1
            nlen = name_tr(i)
            name_temporary = ftrnm(i)

            call tios_var(tr(it),name_temporary(1:nlen)//'\0',id_g1,imap)
            call tios_var(trm(it),name_temporary(1:nlen)//c_str(_MEAN),
     *                    id_g1,imap)
         enddo

c         if (iforc_tr .eq. 12) then
c            idpco2 =  tios_idvar(c_str(PCO2),id_g1,imap)
c         endif

         if (iforc_tr.ge.61 .and. iforc_tr.le.63) then
            idtrtflx  = tios_idvar(c_str(TRTFLX),id_g0,imap)
            idtrtflx1 = tios_idvar(c_str(FLX1),id_g0,imap)
            idtrtflx2 = tios_idvar(c_str(FLX2),id_g0,imap)
            idtrtflx3 = tios_idvar(c_str(FLX3),id_g0,imap)
            idtrtcp   = tios_idvar(c_str(CP),id_g0,imap)
            idtrtevp  = tios_idvar(c_str(EVP),  id_g0,imap)
            idtrtprc  = tios_idvar(c_str(PRC),  id_g0,imap)
            idtrtrlh  = tios_idvar(c_str(RLH),  id_g0,imap)
         endif

      endif
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      call tios_read

      return
      end

c--------------------------------------------------
      subroutine data_out (tenso, nx, ny, npt, en)
c--------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_pbl.h'
      include 'comm_diff.h'
      include 'comm_tracer.h'

      real en(1)
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /tios_id/ iddq, idri, idenm, ifoh ,idmosf, idtm, idep,
     &          idtrtflx,idtrtcp,idtrtflx1,idtrtflx2,idtrtflx3,
     &          idtrtevp,idtrtprc,idtrtrlh
      external h_to_z, comp_rich, out_mean, out_mosf, dept_to_foh, comp_q
     *         ,comp_ep
      integer tios_putvar, tios_putidvar

      if (tios_putvar (t, tenso, 0) .eq. 1) then 
         call zero_em(nz*nxyc, convn)
      endif

      call tios_putvar (pgfx, tenso, 0)
      call tios_putvar (pgfy, tenso, 0)

c.....output mean MODEL variables:      
      if ( tios_putidvar (idenm, tp, tenso, out_mean) .eq. 0 ) then
         call tios_putvar (tm, tenso, out_mean)
      endif


      if (initq .eq. 8.or.use_ice) then
         call tios_putidvar (iddq, tp, tenso, comp_q)
         call tios_putvar (wnd, tenso, 0)
         call tios_putvar (amhum, tenso, 0)
         call tios_putidvar (idep, tp, tenso, comp_ep)
      endif
      if (use_ice) then
         call tios_putvar (cice, tenso, 0)
         call tios_putvar (tsnw, tenso, 0)
      endif

      call tios_putvar (en, tenso, 0)

      call tios_putvar (w((nz-1)*nxyc+1), tenso, 0)
      call tios_putidvar (idri, tp, tenso, comp_rich)


      call tios_putidvar (ifoh, tp, tenso, dept_to_foh)

      if (ibaro.ne.0) call tios_putvar (psi, tenso, 0)

      call tios_putidvar (idtm, tp, tenso, h_to_z)

      call tios_putidvar (idmosf, wint, tenso, out_mosf)

c---------------------------------------------------------------
c--------------------TRACER STUFF-------------------------------
      do i=1,ntrac
         it=npt*nz*(i-1) + 1
         if (tios_putvar(tr(it),tenso,h_to_z).eq.1) then
            call zero_em(nz*nxyc,convn)
         endif
      enddo
      do i=1,ntrac
         it=npt*nz*(i-1) + 1
         if (tios_putvar(trm(it),tenso,h_to_z).eq.1) then
            call zero_em(nz*nxyc,convn)
         endif
      enddo
c                                 forcing and derivative variables
      if (iforc_tr .eq. 12) then
         call tios_putidvar(idpco2,tp,tenso,compute_pco2)
      endif
      if (iforc_tr.ge.61 .and. iforc_tr.le.63 ) then
         call tios_putidvar(idtrtflx, trtflx, tenso, 0)
         call tios_putidvar(idtrtcp,  cp,     tenso, 0)
         call tios_putidvar(idtrtflx1, trtflx1, tenso, 0)
         call tios_putidvar(idtrtflx2, trtflx2, tenso, 0)
         call tios_putidvar(idtrtflx3, trtflx3, tenso, 0)

         call tios_putidvar(idtrtevp,  evap,    tenso, 0)
         call tios_putidvar(idtrtprc,  precip,  tenso, 0)
         call tios_putidvar(idtrtrlh,  relhum,  tenso, 0)
      endif
c---------------------------------------------------------------
c---------------------------------------------------------------


      call tios_save

      return
      end

c------------------------------------------------------------
      subroutine h_to_z 
c------------------------------------------------------------
      include 'comm_data.h'
      include 'comm_para.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
c
c compute vertical coordinate

      x = sqrt(-1.)

      do i = 1, nxyc*nz
         tp(i) = x
      enddo

      do i = 1, nxyc
         z = h(i)/2.
         dz= h(i)/2.
         tp(i) = -z
         do k = 2, nzi(i)
            kn = (k-1)*nxyc
            ik  = kn + i
            ikm  = kn + i - nxyc
            dz = h(ikm) - dz
            z = z + 2.*dz
            tp(ik) = - z
         enddo
      enddo

      return
      end

c------------------------------------------------------------
      subroutine dept_to_foh
c------------------------------------------------------------
      include 'comm_data.h'
      include 'comm_para.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
c
c compute f/H

      do i = 1, nxyc
         tp(i) = f(i)/dept(i)
      enddo


      return
      end

c------------------------------------------------------------
      subroutine comp_rich 
c------------------------------------------------------------
      include 'comm_para.h'
      include 'comm_new.h'
      include 'comm_data.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
c

      parameter (R_COEF  = -0.5 * GRAVTY/1000.)
      parameter (DUZ_0   = 1.e-5)
c
c  compute Ri & put it into tp(*)
c  Ri = -(g/rho0) * d(rho)/dz / (du/dz**2 + du/dz**2)c
c
      if (use_salt) then
         do k = 1, nz-1
            kn = (k-1)*nxyc
            do i = 1, nxyc
               ik  = kn + i
               ikp = ik + nxyc
               uu = u(ik) - u(ikp)
               vv = v(ik) - v(ikp)
               du2 = uu*uu + vv*vv
               if (du2 .lt. DUZ_0) du2 = DUZ_0
               
               tp(ik) = R_COEF * (h(ik) + h(ikp))*(dens(ik) - dens(ikp)) / du2
            enddo
         enddo
      else
         coef = R_COEF * TCOEF
         do k = 1, nz-1
            kn = (k-1)*nxyc
            do i = 1, nxyc
               ik  = kn + i
               ikp = ik + nxyc
               uu = u(ik) - u(ikp)
               vv = v(ik) - v(ikp)
               du2 = uu*uu + vv*vv
               if (du2 .lt. DUZ_0) du2 = DUZ_0
               
               tp(ik) = coef * (h(ik) + h(ikp))*(t(ikp) - t(ik)) / du2
            enddo
         enddo
      endif

      return
      end

      subroutine add_mean_old
c-----------------------------
      include 'comm_data.h'
      include 'comm_new.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /mean_comm/ nmcount

      nmcount = nmcount + 1
      if (nmcount .eq. 1) then
         do i = 1, nz*nxyc
            um(i) = 0.
            vm(i) = 0.
            wm(i) = 0.
            tm(i) = 0.
         enddo
         if (use_salt) then
            do i = 1, nz*nxyc
               salm(i)  = 0.
               densm(i) = 0.
            enddo
         endif
      endif

      do k = 1, nz
         ik0 = (k-1)*nxyc
         do i = ik0+1, ik0+nxyc
            um(i) = um(i) + u(i)
            vm(i) = vm(i) + v(i)
            wm(i) = wm(i) + w(i)
            tm(i) = tm(i) + t(i)
         enddo
      enddo

      if (use_salt) then
         do k = 1, nz
            ik0 = (k-1)*nxyc
            do i = ik0+1, ik0+nxyc
               salm(i)  = salm(i)  + sal(i)
               densm(i) = densm(i) + dens(i)
            enddo
         enddo
      endif

      return
      end

      subroutine out_mean
c--------------------------
      include 'comm_data.h'
      include 'comm_new.h'
      common /grid/ nxp, nyp, nxyc, nz, nbx,nby,ncs,land,nlo,npbc
      common /mean_comm/ nmcount

      coef = 1./real(nmcount)
      nmcount = 0

      do i = 1, nz*nxyc
         um(i) = coef*um(i) 
         vm(i) = coef*vm(i) 
         wm(i) = coef*wm(i) 
         hm(i) = coef*hm(i) 
         tm(i) = coef*tm(i) 
      enddo

      do i = 1, nxyc
         z = 0.5*hm(i)
         dh=  z
         do k = 1, nzi(i)
            ik  = i + (k-1)*nxyc
            tp(ik) = - z
            z = z + 2.*dh 
            dh = hm(ik) - dh
         enddo
      enddo

c      do i = 1, nxyc
c         tp(i) = -0.5*hm(i)
c      enddo
c      do k = 2, nz
c         kn = (k-1)*nxyc
c         do i = 1, nxyc
c            ik  = kn + i
c            ikm = ik - nxyc
c            tp(ik) = tp(ikm) - 0.5 * (hm(ikm) + hm(ik))
c         enddo
c      enddo

      if (use_salt) then
         do i = 1, nz*nxyc
            salm(i)  = coef*salm(i) 
            densm(i) = coef*densm(i) 
         enddo
      endif

      do i = 1, ntrac*nz*nxyc
         trm(i) = coef*trm(i) 
      enddo

      return
      end

      subroutine out_mean_old
c--------------------------
      include 'comm_data.h'
      include 'comm_new.h'
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /mean_comm/ nmcount


      coef = 1./real(nmcount)
      nmcount = 0

      do i = 1, nz*nxyc
         um(i) = coef*um(i) 
         vm(i) = coef*vm(i) 
         wm(i) = coef*wm(i) 
         tm(i) = coef*tm(i) 
      enddo

      if (use_salt) then
         do i = 1, nz*nxyc
            salm(i)  = coef*salm(i) 
            densm(i) = coef*densm(i) 
         enddo
      endif

      return
      end

c------------------------------------------------------------
      subroutine out_mosf
c------------------------------------------------------------
      include 'comm_para.h'
      include 'comm_new.h'
      include 'comm_data.h'
      common /grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common /main/npt

c  for mean field meridional overturning streamfunction:
      call comp_mosf(nxp,nyp,nz,npt,mask,wm,psiw,emx,emy,wint,tp)
c  for instantaneous field meridional overturning streamfunction:
c      call comp_mosf(nxp,nyp,nz,npt,mask,w,psiw,emx,emy,wint,tp)

      return
      end

c------------------------------------------------------------
      subroutine comp_mosf(nx,ny,nz,npt,mask,w,psi,emx,emy,wint,tmp)
c------------------------------------------------------------
c  find the meridional overturning streamfunction

      include 'comm_para.h'
      include 'comm_new.h'

      dimension mask(nx*ny,nz),w(npt,nz)
      dimension emx(npt),emy(npt),wint(ny,nz)
      dimension tmp(ny,2),psi(ny,nz+1)


      parameter (REARTH = 6378000., RAD    = 3.14159265/180.)

      jmax=0
      jmin=ny
      do j = 1, ny
      do i = 1, nx
         ij = (j-1)*nx + i 
         ii = mask(ij,1)
         if (ii.gt.0) then
            tmp(j,1) = emy(ii)
            jmax  = max(jmax,j)
            jmin  = min(jmin,j)       
         endif
      enddo
      enddo
      do j = 1, ny
         tmp(j,2) = 0
      enddo
      do j = 1, ny
      do i = 1, nx
         ij = (j-1)*nx + i 
         do k = 1, nz
            ii = mask(ij,k)
            if (ii.gt.0) then
               tmp(j,2) = max(k,tmp(j,2))
            endif
         enddo
      enddo
      enddo

c     compute wint = zonal integral of w
      call zonal_int(1,nx,ny,nz-1,npt,mask,w,wint,emx)
      
      rnan = sqrt(-1.)
      do j = 1, ny
         do k = 1, nz+1
            psi(j,k) = rnan
         enddo
      enddo

      do j = jmin, jmax
         psi(j,1) = 0.
         psi(j,tmp(j,2)+1) = 0.
      enddo

      do k = 1, tmp(jmin,2)
         psi(jmin,k) = 0.
      enddo
      do k = 1, tmp(jmax,2)
         psi(jmax,k) = 0.
      enddo

c     compute psi from integrating wint in y

      do j = jmin + 1, jmax - 1
         do k = 2, tmp(j,2)
            dy = (1./tmp(j,1) + 1./tmp(j-1,1))/2.
            psi(j,k)=psi(j-1,k) + dy*(wint(j,k)+wint(j-1,k))/2.
         enddo
      enddo

      return
      end

c------------------------------------------------------------
      subroutine zonal_int(iflag, nx,ny,nz,npt,mask,f,fint,emx)
c------------------------------------------------------------
      dimension mask(nx*ny,nz),f(npt,nz),fint(ny,nz),emx(npt)
      
      do j = 1, ny
         do k = 1, nz + iflag
            fint(j,k) = 0.
         enddo
      enddo
      do j = 1, ny
         do i = 1, nx
            ij = (j-1)*nx + i 
            do k = 1, nz
               ii = mask(ij,1)
               if (mask(ij,k).gt.0) then
                  fint(j,k+iflag) = fint(j,k+iflag) + f(ii,k)/emx(ii)
               endif
            enddo
         enddo
      enddo
      
      return
      end

      subroutine add_mean
c-----------------------------
      include 'comm_data.h'
      include 'comm_new.h'
      common /grid/ nxp, nyp, nxyc, nz, nbx,nby,ncs,land,nlo,npbc
      common /mean_comm/ nmcount

      nmcount = nmcount + 1
      if (nmcount .eq. 1) then
         do i = 1, nz*nxyc
            um(i) = 0.
            vm(i) = 0.
            wm(i) = 0.
            hm(i) = 0.
            tm(i) = 0.
         enddo
         if (use_salt) then
            do i = 1, nz*nxyc
               salm(i)  = 0.
               densm(i) = 0.
            enddo
         endif
         do i = 1, nz*nxyc*ntrac
            trm(i) = 0.
         enddo
      endif

      do k = 1, nz
         ik0 = (k-1)*nxyc
         do i = ik0+1, ik0+nxyc
            um(i) = um(i) + u(i)
            vm(i) = vm(i) + v(i)
            hm(i) = hm(i) + h(i)
            wm(i) = wm(i) + w(i)
            tm(i) = tm(i) + t(i)
         enddo
      enddo

      if (use_salt) then
         do k = 1, nz
            ik0 = (k-1)*nxyc
            do i = ik0+1, ik0+nxyc
               salm(i)  = salm(i)  + sal(i)
               densm(i) = densm(i) + dens(i)
            enddo
         enddo
      endif

      do n = 1, ntrac
         in0 = (n-1)*nz*nxyc
         do k = 1, nz
            ik0 = in0 + (k-1)*nxyc
            do i = ik0+1, ik0+nxyc
               trm(i) = trm(i) + tr(i)
            enddo
         enddo
      enddo

      return
      end


c------------------------------------------------------------
      subroutine comp_q
c------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      common /grid/ nxp, nyp, nxyc, nz, nbx,nby,ncs,land,nlo,npbc
      
      do i = 1, nxyc
         tp(i) = QCON * (q(i) + qr(i)) 
      enddo

      return
      end

c------------------------------------------------------------
      subroutine comp_ep
c------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      common /grid/ nxp, nyp, nxyc, nz, nbx,nby,ncs,land,nlo,npbc
      
      do i = 1, nxyc
         tp(i) = ep(i)/sal(i)
      enddo

      return
      end
dyn_topo.f/     849541232   1572  1572  100444  18014     `
      subroutine new_topo (nxp,nyp,nz,npt,zin,dzin,hin,nsig,sigma,dept,h,nptk,nzi)
      dimension zin(nz+1),dzin(nz+1),dept(npt),nptk(nz),h(npt,nz)
     *         ,nzi(npt),hin(nz),sigma(nz)
      include 'comm_new.h'
      
      do k = 1, nz
         do i = 1, npt
c            h(i,k) = -98765432.
            h(i,k) = 0.
         enddo
      enddo
      
      do i = 1, npt
         dep = dept(i)
         n = 1
         do k = 2, nz
            if (dep.lt.zin(k)) goto 10
            n = k
         enddo
   10    nzi(i) = n
      enddo
      
      if (initbt.eq.0) then
         do i = 1, npt
            mz = nzi(i)
            do k = 1, mz
               h(i,k) = dzin(k+1) + dzin(k)
            enddo
         enddo
      elseif (initbt.eq.3) then
         mmz = 0
         do i = 1, npt
            mmz = max(nzi(i),mmz)
         enddo
         do i = 1, npt
            mz = nzi(i)
            do k = 1, mz - 1
               h(i,k) = dzin(k+1) + dzin(k)
            enddo
            if (mz.eq.mmz) then
               h(i,mz) = dzin(mz) + (dept(i)-zin(mz))
            else
               h(i,mz) = dzin(mz+1) + dzin(mz)
            endif
         enddo
      else
         do i = 1, npt
            dep = dept(i)
            mz = nzi(i)
            do k = 1, mz - 1
               h(i,k) = dzin(k+1) + dzin(k)
            enddo
            h(i,mz) = dzin(mz) + (dep-zin(mz))
         enddo
      endif
      
      return
      end

c     ---------------------------------------------------------------------
      subroutine data_init (npt,nptk,nz,isk,u,v,uc,vc,fu,fv,ft,fsal,bdiv,ubar,vbar,use_salt)
c     ---------------------------------------------------------------------
      dimension nptk(nz),isk(npt,nz),bdiv(npt),ubar(npt),vbar(npt),
     *          u(npt,nz),v(npt,nz),uc(npt,nz),vc(npt,nz),
     *          fu(npt,nz), fv(npt,nz), ft(npt,nz), fsal(npt,nz)
      logical use_salt

      do i = 1, npt
         bdiv(i) = 0.
         ubar(i) = 0.
         vbar(i) = 0.
      enddo

      do k = 1, nz
         do j = 1, nptk(k)
            i = isk(j,k)
            u(i,k) = 0.
            v(i,k) = 0.
            uc(i,k) = 0.
            vc(i,k) = 0.
            fu(i,k) = 0.
            fv(i,k) = 0.
            ft(i,k) = 0.
         enddo
      enddo

      if (.not.use_salt) return

      do k = 1, nz
         do j = 1, nptk(k)
            i = isk(j,k)
            fsal(i,k) = 0.
         enddo
      enddo

      return
      end

c     ---------------------------------------------------------------------
      subroutine dfdxk (f,df,npt,npk,nbu,nbx,nby,ncs,lxx,lyx,snx
     *           ,npbc,lpbcw,lpbce,isk)
c     ---------------------------------------------------------------------
c............ a version with Periodic B.C. (Senya Basin)
      implicit real(a-h,o-z),integer(i-n)
      logical use_hi
      common /order/ use_hi
      dimension f(npt),df(npt),snx(nbx),lxx(nbx+ncs,4), lyx(nby)
      dimension lpbcw(npbc), lpbce(npbc),isk(npk)
      
      
      if (use_hi) then
c        compute centered first derivative for entire grid.
         do i = 3, npk - 2
            j = isk(i)
            df(j) = (8.*(f(j+1)-f(j-1)) - (f(j+2)-f(j-2)))/12.
         enddo
c....................... periodic B.C.
         do i = 1, npbc
            i2 = lpbce(i)
            f4 = f(i2)
            f3 = f(i2-1)
            f2 = f(i2-2)
            f1 = f(i2-3)
            
            i1 = lpbcw(i)
            f5 = f(i1)
            f6 = f(i1+1)
            f7 = f(i1+2)
            f8 = f(i1+3)
            
            df(i1)   = (8.*(f6 - f4) - (f7 - f3))/12.
            df(i1+1) = (8.*(f7 - f5) - (f8 - f4))/12.
            df(i2)   = (8.*(f5 - f3) - (f6 - f2))/12.
            df(i2-1) = (8.*(f4 - f2) - (f5 - f1))/12.
         enddo
         
         nb = nbx
         
         if (nbu .eq. -1 .or. nbu .eq. 2) then
            do i = 1, nb
               i1 = lxx(i,1)
               i2 = lxx(i,2)
               f1 = f(i1)
               f2 = f(i2)
               f3 = f(lxx(i,3))
               f4 = f(lxx(i,4))
               df(i1) = 0.            
               df(i2) = snx(i)*( 2.*(f2-f1) + 5.*(f3-f2) - (f4-f3))/6.
            enddo
         else
            do i = 1, nb
               i1 = lxx(i,1)
               i2 = lxx(i,2)
               f1 = f(i1)
               f2 = f(i2)
               f3 = f(lxx(i,3))
               f4 = f(lxx(i,4))
               df(i1) = snx(i)*(11.*(f2-f1) + 7.*(f2 - f3) + 2.*(f4-f3))/6.
               df(i2) = snx(i)*( 2.*(f2-f1) + 5.*(f3-f2) - (f4-f3))/6.
            enddo
         endif
         
      else 
c        compute centered first derivative for entire grid.
         do i = 2, npk - 1
            j = isk(i)
            df(j) = (f(j+1)-f(j-1))/2.
         enddo
         
c....................... periodic B.C.
         do i = 1, npbc
            i2 = lpbce(i)
            f4 = f(i2)
            f3 = f(i2-1)
            i1 = lpbcw(i)
            f5 = f(i1)
            f6 = f(i1+1)
            
            df(i1)   = (f6 - f4)/2.
            df(i2)   = (f5 - f3)/2.
         enddo
         
         nb = nbx
         
         if (nbu .eq. -1 .or. nbu .eq. 2) then
            do i = 1, nb
               i1 = lxx(i,1)
               df(i1) = 0.            
            enddo
         else
            do i = 1, nb
               i1 = lxx(i,1)
               i2 = lxx(i,2)
               f1 = f(i1)
               f2 = f(i2)
               df(i1) = snx(i)*(f2 - f1)
            enddo
         endif
         
      endif
      
      if (nbu .eq. -1 .or. nbu.eq.1) then
c..................set the derivative along the boundary equal to zero.
         do i = 1, nby
            df(lyx(i)) = 0.
         enddo
      endif

      return
c     end of dfdxk.
      end

c     ------------------------------------------------------------------
      subroutine dfdyk(f,df,npt,npk,nbv,nby,nbx,ncs,lyy,lxy,sny,isy)
c     ------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      logical use_hi
      common /order/ use_hi
      dimension f(npt),df(npt),sny(nby),lyy(nby+ncs,4),lxy(nbx)
     *          ,isy(npk)
c   note, isy: k-y-comp  -> x-comp, 
c         lyy: k-y-comp-bound -> x-comp , etc.
c
      if (use_hi) then
         do i = 3, npk-2
            j   = isy(i)
            ip =  isy(i+1)
            im =  isy(i-1)
            df(j)=( 8.*(f(ip)-f(im)) - (f(isy(i+2))-f(isy(i-2))) )/12.
         enddo
         
         nb = nby
         
         if (nbv.eq.-1 .or. nbv.eq.2) then
            do i = 1, nb
               i1 = lyy(i,1)
               i2 = lyy(i,2)
               f1 = f(i1) 
               f2 = f(i2)
               f3 = f(lyy(i,3))
               f4 = f(lyy(i,4))
               df(i1) = 0.            
               df(i2) = sny(i)*(2.*(f2-f1) + 5.*(f3-f2) - (f4-f3))/6.
            enddo
         else
            do i = 1, nb
               i1 = lyy(i,1)
               i2 = lyy(i,2)
               f1 = f(i1)
               f2 = f(i2)
               f3 = f(lyy(i,3))
               f4 = f(lyy(i,4))
               df(i1) = sny(i)*(11.*(f2-f1) + 7.*(f2-f3) + 2.*(f4-f3))/6.
               df(i2) = sny(i)*( 2.*(f2-f1) + 5.*(f3-f2) -    (f4-f3))/6.
            enddo
         endif
         
      else 
         do i = 2, npk-1
            j   = isy(i)
            df(j)=(f(isy(i+1))-f(isy(i-1)))/2.
         enddo
         
         nb = nby
         
         if (nbv.eq.-1 .or. nbv.eq.2) then
            do i = 1, nb
               i1 = lyy(i,1)
               df(i1) = 0.            
            enddo
         else
            do i = 1, nb
               i1 = lyy(i,1)
               i2 = lyy(i,2)
               f1 = f(i1)
               f2 = f(i2)
               df(i1) = sny(i)*(f2-f1)
            enddo
         endif
         
      endif
      
      if(nbv.eq.-1 .or. nbv.eq.1) then
c.....................set the derivative along the x boundary equal to zero.
         do i = 1, nbx
            df(lxy(i)) = 0.
         enddo
      endif

      return
c     end of dfdyk.
      end


c     ---------------------------------------------------------------------
      subroutine dfdx1 (f,df,npt,nbu,nbx,nby,ncs,lxx,lyx,snx
     *           ,npbc,lpbcw,lpbce)
c     ---------------------------------------------------------------------
c............ a version with Periodic B.C. (Senya Basin)
      implicit real(a-h,o-z),integer(i-n)
      logical use_hi
      common /order/ use_hi
      dimension f(npt),df(npt),snx(nbx),lxx(nbx+ncs,4), lyx(nby)
      dimension lpbcw(npbc), lpbce(npbc)


      if (use_hi) then
c        compute fourth order centered first derivative for entire grid.
         do j = 3, npt - 2
            df(j) = (8.*(f(j+1)-f(j-1)) - (f(j+2)-f(j-2)))/12.
         enddo
c....................... periodic B.C.
         do i = 1, npbc
            i2 = lpbce(i)
            f4 = f(i2)
            f3 = f(i2-1)
            f2 = f(i2-2)
            f1 = f(i2-3)
            
            i1 = lpbcw(i)
            f5 = f(i1)
            f6 = f(i1+1)
            f7 = f(i1+2)
            f8 = f(i1+3)
            
            df(i1)   = (8.*(f6 - f4) - (f7 - f3))/12.
            df(i1+1) = (8.*(f7 - f5) - (f8 - f4))/12.
            df(i2)   = (8.*(f5 - f3) - (f6 - f2))/12.
            df(i2-1) = (8.*(f4 - f2) - (f5 - f1))/12.
         enddo
         
         do i = 1, nbx
            i1 = lxx(i,1)
            i2 = lxx(i,2)
            f1 = f(i1)
            f2 = f(i2)
            f3 = f(lxx(i,3))
            f4 = f(lxx(i,4))
            df(i1) = snx(i)*(3.*(f2-f1) + (f2-f3))/2.
c           df(i1) = snx(i)*(11.*(f2-f1) + 7.*(f2 - f3) + 2.*(f4-f3))/6.
            df(i2) = snx(i)*(2.*(f2-f1) + 5.*(f3-f2) + (f3-f4))/6.
         enddo
         
      else                      !second_order
         do j = 2, npt - 1
            df(j) = (f(j+1)-f(j-1))/2.
         enddo
         
c....................... periodic B.C.
         do i = 1, npbc
            i2 = lpbce(i)
            f4 = f(i2)
            f3 = f(i2-1)
            i1 = lpbcw(i)
            f5 = f(i1)
            f6 = f(i1+1)
            df(i1)   = (f6 - f4)/2.
            df(i2)   = (f5 - f3)/2.
         enddo
         
         do i = 1, nbx
            i1 = lxx(i,1)
            i2 = lxx(i,2)
            f1 = f(i1)
            f2 = f(i2)
            df(i1) = snx(i)*(f2 - f1)
         enddo
         
      endif
      
      if (nbu.eq.1) then
c..................set the derivative along the boundary equal to zero.
         do i = 1, nby
            df(lyx(i)) = 0.
         enddo
      endif

      return

      end


c     ------------------------------------------------------------------
      subroutine dfdy1(f,df,npt,nbv,nby,nbx,ncs,lyy,lxy,sny,isy)
c     ------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      logical use_hi
      common /order/ use_hi
      dimension f(npt),df(npt),sny(nby),lyy(nby+ncs,4),lxy(nbx)
     *          ,isy(npt)
c   note, isy: k-y-comp  -> x-comp, 
c         lyy: k-y-comp-bound -> x-comp , etc.
c
      if (use_hi) then
         do i = 3, npt-2
            j   = isy(i)
            ip =  isy(i+1)
            im =  isy(i-1)
            df(j)=( 8.*(f(ip)-f(im)) - (f(isy(i+2))-f(isy(i-2))) )/12.
         enddo

         do i = 1, nby
            i1 = lyy(i,1)
            i2 = lyy(i,2)
            f1 = f(i1)
            f2 = f(i2)
            f3 = f(lyy(i,3))
            f4 = f(lyy(i,4))
            df(i1) = sny(i)*(3.*(f2-f1) + (f2-f3))/2.
c            df(i1) = sny(i)*(11.*(f2-f1) + 7.*(f2-f3) + 2.*(f4-f3))/6.
            df(i2) = sny(i)*(2.*(f2-f1) + 5.*(f3-f2) + (f3-f4))/6.
         enddo
         
      else                      !second_order
         do i = 2, npt-1
            j   = isy(i)
            ip =  isy(i+1)
            im =  isy(i-1)
            df(j) = 0.5* ( f(ip) - f(im) )
         enddo
         do i = 1, nby
            i1 = lyy(i,1)
            i2 = lyy(i,2)
            f1 = f(i1)
            f2 = f(i2)
            df(i1) = sny(i)*(f2 - f1)
         enddo
      endif

      if(nbv.eq.1) then
c.....................set the derivative along the x boundary equal to zero.
         do i = 1, nbx
            df(lxy(i)) = 0.
         enddo
      endif

      return
c     end of dfdy1.
      end

      subroutine baro_dept(npt,nz,nzi,nzi_b,h,lxxk,lyyk,mbc,dept,nz_x,nz_y)
c     ---------------------------------------------------------------------
c...... requires no-slip boundary condition

c...... if point is an x or y boundary point on the k-th grid, but not
c......  the first grid, then it must be treated differently in baro_shap
c......  and baro_updat in order to satisfy boundary conditions

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      dimension h(npt,nz),dept(npt),
     *          lxxk(MXBDY,nz),lyyk(MXBDY,nz),nzi(npt),nzi_b(npt)
     *          ,nz_x(npt),nz_y(npt)

      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +      ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      logical use_hi
      common /order/ use_hi
      
      do i = 1, npt
         nz_x(i) = nzi(i)
         nz_y(i) = nzi(i)
      enddo

c  find x-direction restrictions on depth
      do k =  nz, 2, -1
         do j = 1, nbxk(k)
            i = lxxk(j,k)
            nz_x(i) = k-1
         enddo
      enddo
      k = 1
      do j = 1, nbxk(k)
         i = lxxk(j,k)
         nz_x(i) = nzi(i)
      enddo

      do i = 1, npt
         nzi_b(i) = nz_x(i)
      enddo

      if (use_hi) then
         do k = nz, 2, -1
            nxck = nbxk(k) + ncsk(k)
            do i = 1, nbxk(k)
               j = lxxk(i+nxck,k)
               nz_x(j) = k-1
            enddo
         enddo
         k = 1
         nxck = nbxk(k) + ncsk(k)
         do i = 1, nbxk(k)
            j = lxxk(i+nxck,k)
            nz_x(j) = nzi_b(j)
         enddo
      endif

c  find y-direction restrictions on depth
      do k =  nz, 2, -1
         do j = 1, nbyk(k)
            i = lyyk(j,k)
            nz_y(i) = k-1
         enddo
      enddo
      k = 1
      do j = 1, nbyk(k)
         i = lyyk(j,k)
         nz_y(i) = nzi(i)
      enddo

      do i = 1, npt
         nzi_b(i) = nz_y(i)
      enddo

      if (use_hi) then
         do k = nz, 2, -1
            nyck = nbyk(k) + ncsk(k)
            do i = 1, nbyk(k)
               j = lyyk(i+nyck,k)
               nz_y(j) = k-1
            enddo
         enddo
         k = 1
         nyck = nbyk(k) + ncsk(k)
         do i = 1, nbyk(k)
            j = lyyk(i+nyck,k)
            nz_y(j) = nzi_b(j)
         enddo
      endif

      do i = 1, npt
         nzi_b(i) = min(nz_x(i),nz_y(i))
      enddo

      do i = 1, npt
         dept(i) = h(i,1)
         do k = 2, nzi_b(i)
            dept(i) = dept(i) + h(i,k)
         enddo
      enddo

      return
      end


      subroutine baro_shap (nstep,npt,nz,nzi,nzi_b,dept,h,uc,vc,ubar,vbar,u,v,
     *                      lxxk,lyyk)
c---------------------------------------------------------------------------


c    This subroutine is responsible for preserving the rigid lid 
c    assumption. It must be called immediately before ddiv to
c    work properly

c    Note that in the non-constant depth scenario, we need
c                div(sum(uc_k)) = sum(div(uc_k)).

c      - We need the same divergence operators on both sides.
c    We accomplish this by using the k=1 divergence operator
c    on all levels, assuming uc(i,k)=0 at all 'mud' (non-ocean) points.

c      - In order for the divergence and summation (over k) operators
c    to commute, we need also need the summation to be independent of
c    horizontal position, hence the sum must be over all 'nz' levels
c    but no normal vertical flow through the bottom requires that
c    div(uc_k) = 0 at all 'mud' points.

c    Thus we have two constraints while computing divergences in ddiv:
c         uc_k=0 and div(uc_k)=0 at mud points 

c    NOTE: A distinction is made between 'mud' points and 'land'
c    points. A 'mud' point is by definitions a point which is
c    not water on some level k>1, but is water on the k=1 level.
c    These 'fixes' are not done on the land points, only mud points.

c    Zero mudpoint transport (uc_k = 0) is done in ddiv. 

c    Zero mudpoint divergence (div(uc_k) = 0) is accomplished by 
c    enforcing the normal component of velocity to be zero at
c    one(two) grid point(s) adjacent to land in the case of
c    second(fourth) order approximations to the derivatives.  This
c    is done here and in bcset, but in order for the total transport to
c    remain fixed, we must redistribute the zero-ed out barotropic
c    transport in this routine.  The redistribution of ubar(vbar) is 
c    determined by nzi_b. This restores the correct barotropic transport 
c    (which was spoiled by bcset and the shapiro filter).

c----NHN:Dec.21,95

      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      dimension h(npt,nz),uc(npt,nz),vc(npt,nz),ubar(npt),vbar(npt)
      dimension u(npt,nz),v(npt,nz)
      dimension dept(npt),nzi(npt),nzi_b(npt)
      dimension lxxk(MXBDY,nz), lyyk(MXBDY,nz)
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +      ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)

      do i = 1, npt
         do k = 1, nzi_b(i)
            hi = h(i,k)
            uc(i,k) = u(i,k)*hi
            vc(i,k) = v(i,k)*hi
         enddo
      enddo
      do i = 1, npt
         do k = nzi_b(i)+1, nzi(i)
            uc(i,k) = 0.
            vc(i,k) = 0.
         enddo
      enddo

      call baro_sum (npt, nz, nzi_b, uc, vc, u, v)
      call baro_scale (npt, u, v, dept)

      do i = 1, npt
         do k = 1, nzi_b(i)
            uc(i,k) = uc(i,k) + h(i,k)*(ubar(i) - u(i,1))
         enddo
         do k = 1, nzi_b(i)
            vc(i,k) = vc(i,k) + h(i,k)*(vbar(i) - v(i,1))
         enddo
      enddo

      call decap (npt, nz, nzi, u,v,uc,vc,h)

      return
      end

dyn_trac_init.f/847221371   1572  1572  100444  23287     `
#define c_str(s) ('s\0')
c------------------------------------------------------------
      subroutine hfx_pert_init
c------------------------------------------------------------
      include 'comm_para.h'
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_tracer.h'

      real inp_flt, inp_days
      logical inp_def
      dimension flt(100)

      ihfprt = inp_int(c_str(Hflx_prt),0)
      if (ihfprt .gt. 0) then
         hfprt_amp = inp_flt(c_str(Hflx_prt_amp),15.0)
         hfprt_lat = inp_flt(c_str(Hflx_prt_lat),20.0)
      endif

      return
      end

c------------------------------------------------------------
      subroutine tracer_input(npt,nz,ntimes,nstart,nstep)
c------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_tracer.h'

      real inp_flt, inp_days
      logical inp_def
      dimension flt(100)      

      call array_init(npt,nz)

      delt = inp_days (c_str(Time_step), 1./24.)
      stpd = 1./delt
      ntrcont     = stpd*inp_days(c_str(Tr_int_step),15.)
      init_tr     = inp_int(c_str(Tr_init),0)
      ifilt_tr    = inp_int(c_str(Tr_filt),1) 
      iforc_tr    = inp_int(c_str(Tr_forcing),0)
      icl_tr      = inp_int(c_str(Clim_Tr),0)
      ipp_tr      = inp_int(c_str(Tr_pp),0)
      itanom_init = inp_int(c_str(Tanom_init),0)

      igas_ex    = inp_int(c_str(Gas_Ex),0)
      ibio       = inp_int(c_str(Biology),0)


      number1 = inp_sarr(c_str(Tr_name),0,ftrnm,80,name_tr,ftrnm)
      number2 = inp_sarr(c_str(Tr_clim_file),0,fbtr,80,n_tr,fbtr)

      if (init_tr .eq. 21) then
         call mem_alloc(p_xga, ntrac, 2, 'xga')
         call mem_alloc(p_yga, ntrac, 2, 'yga')
         call mem_alloc(p_dga, ntrac, 2, 'dga')
         call mem_alloc(p_rga, ntrac, 2, 'rga')
         
         i = inp_rarr(c_str(Tr_gs_lon), ntrac, xga, xga)
         j = inp_rarr(c_str(Tr_gs_lat), ntrac, yga, yga)
         k = inp_rarr(c_str(Tr_gs_dp),  ntrac, dga, dga)
         l = inp_rarr(c_str(Tr_gs_rad), ntrac, rga, rga)
      endif
c     
c                                 for c14 with constant exchange,
c                                 read co2 gas exchange flux in units
c                                 of moles CO2/m2/yr from input file
c
      if (iforc_tr.eq.2) then
         co2geflx   = inp_flt(c_str(CO2_gflx),20.)
         factor_c14 = co2geflx/(100.*24.*365.*3600.)
      endif

c      ihfprt = inp_int(c_str(Hflx_prt),0)
c      if (ihfprt .gt. 0) then
c         hfprt_amp = inp_flt(c_str(Hflx_prt_amp),15.0)
c         hfprt_lat = inp_flt(c_str(Hflx_prt_lat),20.0)
c      endif

      if (iforc_tr.eq.11 .or. iforc_tr.eq.12) then
         chs        =          inp_flt(c_str(CHS),0.275)
         biomin     =          inp_flt(c_str(Bio_min),0.05)
         expar      =          inp_flt(c_str(Expar),0.8)
         biofactor  =          inp_flt(c_str(Bio_factor),0.5)
         dpml       =          inp_flt(c_str(DPML),50.0)
         redf_no3_tco2 =       inp_flt(c_str(Redf_NO3_TCO2),7.25)
         redf_no3_o2   =       inp_flt(c_str(Redf_NO3_O2),10.0)
      endif

      if (iforc_tr.eq.21 .or .iforc_tr.eq.23) then
         f11_a1   = inp_flt(c_str(f11_a1), -232.0411)
         f11_a2   = inp_flt(c_str(f11_a2),  322.5546)
         f11_a3   = inp_flt(c_str(f11_a3),  120.4956)
         f11_a4   = inp_flt(c_str(f11_a4),  -1.39165)
         f11_b1   = inp_flt(c_str(f11_b1),  -0.146531)
         f11_b2   = inp_flt(c_str(f11_b2),  0.093621)
         f11_b3   = inp_flt(c_str(f11_b3), -0.0160693)
      endif

      if (iforc_tr.eq.22. or. iforc_tr.eq.23) then
         f12_a1   = inp_flt(c_str(f12_a1), -220.2120)
         f12_a2   = inp_flt(c_str(f12_a2),  301.8695)
         f12_a3   = inp_flt(c_str(f12_a3),  114.8533)
         f12_a4   = inp_flt(c_str(f12_a4),  -1.39165)
         f12_b1   = inp_flt(c_str(f12_b1), -0.147728)
         f12_b2   = inp_flt(c_str(f12_b2),  0.093175)
         f12_b3   = inp_flt(c_str(f12_b3),-0.0157340)
      endif

      if (iforc_tr .ge. 61 .and. iforc_tr .le. 63) then
c         fake_flux = inp_flt(c_str(Fake_Flux),0.0)
         call mem_alloc(p_efac1 ,  npt,2,'efac1')
         call mem_alloc(p_efac2 ,  npt,2,'efac2')
         call mem_alloc(p_evap,  3*npt,2,'evap' )
         call mem_alloc(p_precip,3*npt,2,'precip')
         call mem_alloc(p_relhum,3*npt,2,'relhum')
         call mem_alloc(p_abswin,3*npt,2,'abswin')
         call mem_alloc(p_trtflx,  npt,2,'trtflx')
         call mem_alloc(p_trtflx1, npt,2,'trtflx1')
         call mem_alloc(p_trtflx2, npt,2,'trtflx2')
         call mem_alloc(p_trtflx3, npt,2,'trtflx3')
         call mem_alloc(p_source,npt,2,'source')
         call mem_alloc(p_rk,    npt,2,'rk')
         call mem_alloc(p_cp,    npt,2,'cp')
         call mem_alloc(p_donf1,  npt,2,'donf1')
         call mem_alloc(p_donf2,  npt,2,'donf2')
         call mem_alloc(p_donam,  npt,2,'donam')
         call mem_alloc(p_donphz, npt,2,'donphz')
         call tritium_init(npt,nz,nstart,nstep)
      endif

      if (igas_ex.eq.1 .or. igas_ex.eq.2) then
         n_atm = inp_str(c_str(Tr_atm_forc),'none',fatf)
         call odb_open(idf_tr(1),fatf(1:n_atm),0)
         call odb_rddm(idf_tr(1),'T',nt_tratm)
         call odb_rddm(idf_tr(1),'LAT',nlat_tratm)
         call mem_alloc(p_tr_atm,  nt_tratm*nlat_tratm,2,'tr_atm')
         call mem_alloc(p_tr_tgrid,nt_tratm,2,'tr_tgrid')
         call mem_alloc(p_tr_latgrid,nlat_tratm,2,'tr_latgrid')
         call odb_rdgr(idf_tr(1),'T',nt_tratm,tr_tgrid)
         call odb_rdgr(idf_tr(1),'LAT',nlat_tratm,tr_latgrid)
         if ((iforc_tr.eq.1).or.(iforc_tr.eq.2)) then
            call odb_rdvar(idf_tr(1),'c14',tr_atm)
         elseif (iforc_tr .eq. 12) then
            call odb_rdvar(idf_tr(1),'pco2',tr_atm)
         elseif (iforc_tr .eq. 21) then
            call odb_rdvar(idf_tr(1),'f11',tr_atm)
         elseif (iforc_tr .eq. 22) then
            call odb_rdvar(idf_tr(1),'f12',tr_atm)
         endif
      endif

      return
      end




c----------------------------------------------------
      subroutine tritium_init(npt,nz,nstart,nstep)
c----------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_tracer.h'
c      dimension ev(npt,1),pr(npt,1),rh(npt,1),aw(npt,1)

      character c70*70, c5*5
      data ireawr /0/
      data ireadon /0/
      pi = asin(1.)*2.
      
c
c                                  Read in doney's arrays
c                                       f1,f2,am,phz
c
         n_rdonf1   = inp_str(c_str(Tr_donf1)  ,'none',fdonf1)
         n_rdonf2   = inp_str(c_str(Tr_donf2)  ,'none',fdonf2)
         n_rdonam   = inp_str(c_str(Tr_donam)  ,'none',fdonam)
         n_rdonphz  = inp_str(c_str(Tr_donphz) ,'none',fdonphz)
         call odb_open(idf_donf1, fdonf1(1:n_rdonf1),0)
         call odb_open(idf_donf2, fdonf2(1:n_rdonf2),0)
         call odb_open(idf_donam, fdonam(1:n_rdonam),0)
         call odb_open(idf_donphz,fdonphz(1:n_rdonphz),0)

         call data_on_model_grid(idf_donf1, ldonf1, 'F1')
         call read_zt(idf_donf1,ldonf1,npt,1,1,'F1',tp, donf1(1))

         call data_on_model_grid(idf_donf2, ldonf2, 'F2')
         call read_zt(idf_donf2,ldonf2,npt,1,1,'F2',tp, donf2(1))

         call data_on_model_grid(idf_donam, ldonam, 'AM')
         call read_zt(idf_donam,ldonam,npt,1,1,'AM',tp, donam(1))

         call data_on_model_grid(idf_donf1, ldonphz, 'F1')
         call read_zt(idf_donphz,ldonphz,npt,1,1,'PHZ',tp, donphz(1))

c
c                                       read in atmospheric data:
c                                           relative humidity(m/yr)
c                                           evaporation(m/yr)
c                                           precipitation(m/yr)
c
         n_rdonrh   = inp_str(c_str(Tr_donrh)  ,'none',fdonrh)
         n_rdonevp  = inp_str(c_str(Tr_donevp) ,'none',fdonevp)
         n_rdonprcp = inp_str(c_str(Tr_donprcp),'none',fdonprcp)
         n_rdonabwn = inp_str(c_str(Tr_donabwn),'none',fdonabwn)
         call odb_open(idf_donrh,  fdonrh(1:n_rdonrh),0)
         call odb_open(idf_donevp, fdonevp(1:n_rdonevp),0)
         call odb_open(idf_donprcp,fdonprcp(1:n_rdonprcp),0)
         call odb_open(idf_donabwn,fdonabwn(1:n_rdonabwn),0)

         call odb_rddm(idf_donevp, 'T', nevap)
         call mem_alloc(p_tdoney,nevap,2,'tdoney')
         call odb_rdgr(idf_donevp,'T',nevap, tdoney)

         call it_catch(nevap,tdoney,nstart,it1,it2,tscl)

         idoney = it2

         call data_on_model_grid(idf_donevp, levap, 'evap')
         call read_zt(idf_donevp,levap,npt,1,it1,'evap',tp,evap(1))
         call read_zt(idf_donevp,levap,npt,1,it2,'evap',tp,evap(1+npt))

         call data_on_model_grid(idf_donprcp, lprecip, 'precip')
         call read_zt(idf_donprcp,lprecip,npt,1,it1,'precip',tp,precip(1))
         call read_zt(idf_donprcp,lprecip,npt,1,it2,'precip',tp,precip(1+npt))

         call data_on_model_grid(idf_donrh, lrhum, 'relhum')
         call read_zt(idf_donrh,lrhum,npt,1,it1,'relhum',tp,relhum(1))
         call read_zt(idf_donrh,lrhum,npt,1,it2,'relhum',tp,relhum(1+npt))

         call data_on_model_grid(idf_donabwn, labwn, 'abswin')
         call read_zt(idf_donabwn,labwn,npt,1,it1,'abswin',tp,abswin(1))
         call read_zt(idf_donabwn,labwn,npt,1,it2,'abswin',tp,abswin(1+npt))

         do i=1,npt
            evap(i+2*npt)=evap(i)+tscl*(evap(i+npt)-evap(i))
            precip(i+2*npt)=precip(i)+tscl*(precip(i+npt)-precip(i))
            relhum(i+2*npt)=relhum(i)+tscl*(relhum(i+npt)-relhum(i))
            abswin(i+2*npt)=abswin(i)+tscl*(abswin(i+npt)-abswin(i))
         enddo

c                                  BEGIN STUFF FROM CHRISTOPH'S CODE:
c                                     (read ascii files)

      open(15,file='/home/keithr/MODEL/tritium_source_wr',
     *      access='sequential', form='formatted')
      open(19,file='/home/keithr/MODEL/doney_input/factor_scores.dat',
     *  form='formatted',status='unknown')

c---compute monthly rate of tritium input according
c   to roether and weiss (1980), constant source over
c   one year; i.e. the source is compute newly once
c   a year
c
c    read time curves
c      print*,' !!!!!!!!!! ireawr  ',ireawr
      if(ireawr.eq.0)then
        rewind 15 
        read(15,'(a70)')c70
        do l=1,newr
          read(15,'(f7.1,6(3x,f7.1))')
     *      souryr(l),cp50n(l),cp50s(l),cr50n(l),
     *      sp50n(l),sp50s(l),sr50n(l)
c          write(6,'(i2,1x,f7.1,6(3x,f7.1))')
c     *      l,souryr(l),cp50n(l),cp50s(l),cr50n(l),
c     *      sp50n(l),sp50s(l),sr50n(l)
        enddo
        do l=1,3
          read(15,'(a5,i2)')c5,ioc
c          print*,' ioc ',ioc
          read(15,'(a5)')c5
          do n=16,1,-1
            read(15,'(f6.1,f5.2,f5.2,f6.0,f6.0,f6.3,f8.1,
     *        f7.1,f6.2,f5.1,f7.2)')
     *        souphi(n),soue(n,ioc),soup(n,ioc),sourr(n,ioc),
     *        sourv(n,ioc),sousp(n,ioc),soua(n,ioc),soudep(n,ioc),
     *        souiep(n,ioc),souir(n,ioc),souiv(n,ioc)
c            write(6,'(f6.1,f5.2,f5.2,f6.0,f6.0,f6.3,f8.1,
c     *        f7.1,f6.2,f5.1,f7.2)')
c     *        souphi(n),soue(n,ioc),soup(n,ioc),sourr(n,ioc),
c     *        sourv(n,ioc),sousp(n,ioc),soua(n,ioc),soudep(n,ioc),
c     *        souiep(n,ioc),souir(n,ioc),souiv(n,ioc)
          enddo
          do n=17,32
            read(15,'(f6.1,f5.2,f5.2,f6.0,f6.0,f6.3,f8.1,
     *        f7.1,f6.2,f5.1,f7.2)')
     *        souphi(n),soue(n,ioc),soup(n,ioc),sourr(n,ioc),
     *        sourv(n,ioc),sousp(n,ioc),soua(n,ioc),soudep(n,ioc),
     *        souiep(n,ioc),souir(n,ioc),souiv(n,ioc)
c            write(6,'(f6.1,f5.2,f5.2,f6.0,f6.0,f6.3,f8.1,
c     *        f7.1,f6.2,f5.1,f7.2)')
c     *        souphi(n),soue(n,ioc),soup(n,ioc),sourr(n,ioc),
c     *        sourv(n,ioc),sousp(n,ioc),soua(n,ioc),soudep(n,ioc),
c     *        souiep(n,ioc),souir(n,ioc),souiv(n,ioc)

          enddo
        enddo

c
c   years to which runoff curve should be extrapolated
      do n=1,neextr
        yrextr(n)=souryr(newr)+real(n)
      enddo
c
c   linear/expon. extrapolation of runoff
      do n=1,neextr
c       cr50ne(n)=cr50n(newr)+real(n)*(cr50n(newr)-cr50n(newr-1))
        cr50ne(n)=cr50n(newr)*exp(-deccon*dt*12.*real(n))
        expo=exp(-deccon*dt*12.*real(n))
c        print*,' n deccon dt expo ',n,deccon,dt,expo
c        print*,' n cr50ne cr50n(newr) ',n,cr50ne(n),cr50n(newr)
      enddo       
        ireawr=1
      endif

c                                            read Doney's stuff

c---read coefficient time series (first two principal 
c   components of doneys's tritium precip. function)
c   and assoc. spatial patterns
c
        do n=1,nedon 
          read(19,'(f8.1,2(1x,f6.3))')donyr(n),
     *      (cptdon(n,m),m=1,2)
c          write(6,'(f8.1,2(1x,f6.3))')donyr(n),
c     *      (cptdon(n,m),m=1,2)
       enddo


      return
      end
c------------------------------------------------------------
      subroutine tracer_init(npt,nz,nstart,nxp,nyp,iox,trmf,hmf,xm,ym,tmpry)
c------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_para.h'
      include 'comm_new.h'
      include 'comm_tracer.h'
      dimension trmf(npt,nz,ntrac),hmf(npt,nz),tmpry(1)
      dimension xm(1),ym(1)
      dimension iox(1)
      dimension idx(3)

      nptz = npt*nz

c                                       TR_INIT = 0
      if (init_tr .eq. 1) then
         do j=1,ntrac
            do i=1,npt
               do k=1,nz
                  trmf(i,k,j) = 0.0
               enddo
            enddo
         enddo
      endif
c                                       TR_INIT = 100.
c                                        Using Toggweiler's units, 
c                                        equivalent to initializing ocean
c                                        ocean with c14=0;
      if (init_tr .eq. 2) then
         do j=1,ntrac
            do i=1,npt
               do k=1,nz
                  trmf(i,k,j) = 100.0
               enddo
            enddo
         enddo
      endif

c                                        TR_INIT = latitude

      if (init_tr .eq. 5) then
         call latitude_init(npt,nz,ntrac,nxp,nyp,iv_bot,
     &       init_tr,iox,trmf,hmf,xm,ym)
      endif

      if (init_tr .eq. 6) then
         call sin_lat_init(npt,nz,ntrac,nxp,nyp,iv_bot,
     &       init_tr,iox,trmf,hmf,xm,ym)
      endif

c                                       TR_INIT = depth
      if (init_tr .eq. 10) then
         call z_init(npt,nz,iv_bot,init_tr,trmf,hmf)
      endif

      if (init_tr .eq. 21) then
         do itrac=1,ntrac
            call gauss_init(npt,nz,ntrac,itrac,nxp,nyp,
     &          dga,rga,yga,xga,iox,xm,ym,trmf,hmf)
         enddo
      endif

      if (icl_tr.eq.1 .or. icl_tr.eq.2) then
         call tr_data_in(npt,nz)
      endif

      return
      end

c     ------------------------------------------------------------
      subroutine latitude_init(npt,nz,ntrac,nxp,nyp,iv_bot,
     &      init_tr,iox,trm,hm,xm,ym)
c     ------------------------------------------------------------
c                          this subroutine is only appropriate for
c                          a tropical domain (30S <-> 30N)
c
      implicit real(a-h,o-z),integer(i-n)
      dimension iox(npt)
      dimension trm(npt,nz),hm(npt,nz)
      dimension xm(1),ym(1),zz(100)

      mz = nz
      if (iv_bot .eq. 4) mz = nz-1
c
      do i=1,npt
         j=((iox(i)-1)/nxp)+1
         do k=1,mz
            trm(i,k) = ym(j)
         enddo
      enddo

      return
      end

c     ------------------------------------------------------------
      subroutine sin_lat_init(npt,nz,ntrac,nxp,nyp,iv_bot,
     &      init_tr,iox,trm,hm,xm,ym)
c     ------------------------------------------------------------
c                          this subroutine is only appropriate for
c                          a tropical domain (30S <-> 30N)
c
      implicit real(a-h,o-z),integer(i-n)
      dimension iox(npt)
      dimension trm(npt,nz,ntrac),hm(npt,nz)
      dimension xm(1),ym(1),zz(100)
      parameter (RTODEG = 180./3.14159265)

      

      mz = nz
      if (iv_bot .eq. 4) mz = nz-1
c
      do i=1,npt
         j=((iox(i)-1)/nxp)+1
         rlat = ym(j)/rtodeg
         do k=1,mz
            if (ym(j).ge. 0.0) then
               trm(i,k,1) = sin(rlat)
c               trm(i,k,1) = sin(ym(j))
            else
               trm(i,k,1) = 0.0
            endif
         enddo
      enddo


      do i=1,npt
         j=((iox(i)-1)/nxp)+1
         rlat = ym(j)/rtodeg
         do k=1,mz
            if (ym(j).le. 0.0) then
               trm(i,k,2) = -sin(rlat)
            else
               trm(i,k,2) = 0.0
            endif
         enddo
      enddo


      do i=1,npt
         j=((iox(i)-1)/nxp)+1
         do k=1,mz
            trm(i,k,3) = ym(j)
         enddo
      enddo

      return
      end

c     ------------------------------------------------------------
      subroutine gauss_init(npt,nz,ntrac,itrac,nxp,nyp,
     &        dga,rga,yga,xga,iox,xm,ym,tr,hm)
c     ------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension iox(npt), xm(1), ym(1), zz(100)
      dimension dga(ntrac),rga(ntrac),yga(ntrac),xga(ntrac)
      dimension tr(npt,nz,ntrac), hm(npt,nz)

      do indx=1,npt
         j = (iox(indx)-1)/nxp + 1
         i = iox(indx) - (j-1)*nxp

         zz(1) = 0.5*hm(indx,1)
         
         termx = exp(-((xm(i)-xga(itrac))/rga(itrac))**2.)
         termy = exp(-((ym(j)-yga(itrac))/rga(itrac))**2.)
         termz = exp(-zz(1)/dga(itrac))
         tr(indx,1,itrac) = termx*termy*termz
         
         do k=2,nz
            zz(k)=zz(k-1) + 0.5*(hm(indx,k-1)+hm(indx,k))
            termz = exp(-zz(k)/dga(itrac))
            tr(indx,k,itrac) = termx*termy*termz
         enddo

      enddo

      return
      end


c     ------------------------------------------------------------
      subroutine z_init(npt,nz,iv_bot,init_tr,trm,hm)
c     ------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      dimension trm(npt,nz),hm(npt,nz)
      dimension zz(100)

      mz = nz
      if (iv_bot .eq. 4) mz = nz-1
c
      do i=1,npt
         trm(i,1) = 0.5*hm(i,1)
         do k=2,mz
            trm(i,k) = trm(i,k-1) + 0.5*(hm(i,k-1)+hm(i,k))
         enddo
      enddo

      return
      end
c     -------------------------------------------------------
      subroutine tr_data_in(npt,nz)
c     -------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_tracer.h'
      dimension idx(3)

      npts = npt*nz*ntrac

      do i=1,ntrac
         ipoint = (i-1)*npt*nz + 1
         nlen  = n_tr(i)
         nlen2 = name_tr(i)
         name_temporary  = fbtr(i)
         name_temporary2 = ftrnm(i)

         call odb_open(idf_trclim(i),name_temporary(1:nlen),0)
         call odb_rddm(idf_trclim(i),'Z',nztr)
         call odb_rddm(idf_trclim(i),'T',ntimes)

         call mem_alloc(p_ztrclim,nztr,2,'ztrclim')
         call odb_rdgr(idf_trclim(i),'Z',nztr,ztrclim)

         call data_on_model_grid(idf_trclim(i),lclm,name_temporary2(1:nlen2))
         call read_linz(idf_trclim(i),lclm,npt,mpack,nz,nztr,1,hclim,
     &          trclim(ipoint), ztrclim,tp,name_temporary2(1:nlen2))
c         call read_linz2(idf_trclim(i),lclm,npt,mpack,nz,nztr,1,hclim,
c     &          trclim(ipoint), ztrclim,tp,name_temporary2(1:nlen2))
      enddo

      if (init_tr.eq.11) then
         call copya2b(npts,trclim,tr)
      endif

c      write(*,*) " idf_trclim(1)= ", idf_trclim(1)
c      write(*,*) " lclm= ", lclm
c      write(*,*) " mpack= ", mpack
c      write(*,*) " after copya2b: "
c      write(*,*) " name_temporary= ", name_temporary(1:nlen)
c      write(*,*) " name_temporary2= ", name_temporary2(1:nlen2)
c      write(*,*) " nztr= ", nztr
c      write(*,*) " npt= ", npt
c      write(*,*) " ipoint= ", ipoint
c      write(*,*) " ntimes= ", ntimes

      return
      end


c     ------------------------------------------------------------
      subroutine array_init(npt,nz)
c     ------------------------------------------------------------
      include 'comm_new.h'
      include 'comm_data.h'
      include 'comm_tracer.h'
      common /all_loc/ memory_used
c
c            comment:  the two arrays tramt(ntrac,nz+1,2)
c                                 and trint(ntrac,nz+1,2)
c                      are dimensionalized;
c                      "2" refers to the fact that tracer
c                      amount and tracer variance are calculated;

c      nptz = npt*nz
c      nptr = npt*nz*ntrac
      
      call mem_alloc(p_trclim,2*npt*nz*ntrac,2,'trclim')

c      call mem_alloc(p_wspeed,2*npt,2,'wspeed')

c      ncons = 3
cc      nptint = (nz+1)*ntrac*2
c      nptint = (nz+1)*ntrac*ncons
c      call mem_alloc(p_tramt,nptint,2,'tramt')
c      call mem_alloc(p_trfirst,nptint,2,'trfirst')

      return
      end

c-------------------------------------------------------------------
      subroutine shit(npt,nz,ntrac,tr)
c-------------------------------------------------------------------
      real tr(npt,nz,ntrac)
      write(*,*) " tr(1,1,1)= ", tr(1,1,1)
      write(*,*) " tr(1,2,1)= ", tr(1,2,1)
      write(*,*) " tr(1,3,1)= ", tr(1,3,1)
      write(*,*) " tr(1,4,1)= ", tr(1,4,1)
      write(*,*) " tr(1,5,1)= ", tr(1,5,1)
      write(*,*) " tr(1,6,1)= ", tr(1,6,1)
      write(*,*) " tr(1,7,1)= ", tr(1,7,1)
      write(*,*) " tr(1,8,1)= ", tr(1,8,1)
      write(*,*) " tr(1,9,1)= ", tr(1,9,1)
      return
      end

c----------------------------------------------------------------------------- 
      subroutine read_linz2(idf,key,NPT,MPT,NZ,MZ,it, hdat,fdat,zvert,fvert,tag)
c----------------------------------------------------------------------------- 
      implicit real(a-h,o-z),integer(i-n)
      dimension hdat(npt,1),fdat(npt,1), zvert(1),fvert(1)
      character*(*) tag
      include 'comm_new.h'
      include 'comm_data.h'

      dimension aa(npt,1), bb(mpt,1)
      pointer   (p_aa, aa), (p_bb, bb)
      
      write(*,*) " within read_linz2: "
      write(*,*) " key= ", key
      write(*,*) " idf= ", idf
      write(*,*) " npt= ", npt
      write(*,*) " mpt= ", mpt
      write(*,*) " nz= ", nz
      write(*,*) " mz= ", mz

      if (key .eq. 0) then
         call mem_alloc(p_aa, MZ*npt, 2, 'AA space in read_linz')
      
         do k = 1, MZ
            call odb_rd1v3(idf, k, it, tag, aa(1,k)) 
         enddo

         do i = 1, npt 
            do k = 1, mz
               fvert(k) = aa(i,k) 
            enddo
            
            call zlin_intrp (i, npt,nz,mz, hdat,fdat,zvert,fvert)
         enddo

         call mem_free(p_aa, MZ*npt, 2)

      else
         call mem_alloc(p_bb, MZ*mpt, 2, 'BB space in read_linz')
      
         do k = 1, MZ
            call odb_rd1v3(idf, k, it, tag, bb(1,k))
         enddo

         call zlin_blin(NPT,MPT,NZ,MZ,ixd,im2d,blcf,bb,hdat,fdat,zvert,fvert)

         call mem_free(p_bb, MZ*mpt, 2)
      endif

      return
      end

dyn_tracer.f/   846871132   1572  1572  100666  22526     `
c--------------------------------------------------
      subroutine hflx_pert(npt,nz,nx,ny,nstep,yy)
c--------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_data.h'
      include 'comm_new.h'
      include 'comm_tracer.h'
      dimension yy(ny)

      qcon_inv = 1./QCON      
      add_term = qcon_inv*hfprt
c                                   apply perturbation (hfprt) 
c                                   uniformly over domain;
      if (ihfprt .eq. 1) then
         do i=1,npt
            q(i) = q(i) + add_term
         enddo
c                                    apply perturbation poleward
c                                    of specified latitude (hfprt_lat)
c                                    but w/ hemispheric symmetry
      elseif (ihfprt .eq. 2) then
         do i=1,npt
            j=(iox(i)-1)/nx + 1
            if (abs(yy(j)).ge.hfprt_lat) then
               q(i) = q(i) + add_term
            endif
         enddo
c                                   apply only in northern hemisphere
      elseif (ihfprt .eq. 3) then
         do i=1,npt
            j=(iox(i)-1)/nx + 1
            if (yy(j).ge.hfprt_lat) then
               q(i) = q(i) + add_term
            endif
         enddo
c                                   apply only in southern hemisphere
      elseif (ihfprt .eq. 4) then
         do i=1,npt
            j=(iox(i)-1)/nx + 1
            if (yy(j).le.hfprt_lat) then
               q(i) = q(i) + add_term
            endif
         enddo
      endif

      return
      end

c--------------------------------------------------
      subroutine force_tritium2(npt,nz,ntrac,nstep,nxp,nyp,dt,
     &         juljar,rjuljar,nzi,
     &         yy,t,evp,prc,rlh,abw,flx,tr,ftr,hm,iox,tpf)
c--------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_tracer.h'
      parameter(spyr=365.*86400.)
      parameter(ss1972=1958.6/293.8)
      dimension yy(1)
      dimension evp(npt,1),prc(npt,1),rlh(npt,1),abw(npt,1)
      dimension flx(1)
      dimension t(npt,nz),tr(npt,nz,ntrac),ftr(npt,nz,ntrac),hm(npt,nz)
      dimension iox(npt),nzi(npt)
      dimension tpf(npt,1)

      pi = asin(1.)*2.
      
      rlambda = 12.43*365.*24.*3600.
      decay_term  = exp(-dt*alog(2.)/rlambda) - 1.
      decay_term  = decay_term/dt

c                                       RADIOACTIVE DECAY
      do i=1,npt
         do k=1,nzi(i)
             trit_sink = -hm(i,k)*tr(i,k,1)*decay_term
             ftr(i,k,1) = ftr(i,k,1)-trit_sink
             ftr(i,k,2) = ftr(i,k,2)+trit_sink
          enddo
      enddo

      return
      end

c--------------------------------------------------
      subroutine force_tritium(npt,nz,ntrac,nstep,nxp,nyp,dt,
     &         juljar,rjuljar,nzi,
     &         yy,t,evp,prc,rlh,abw,flx,tr,ftr,hm,iox,tpf)
c--------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_tracer.h'
      parameter(spyr=365.*86400.)
      parameter(ss1972=1958.6/293.8)
      parameter(trit_offset=100.0)
      dimension yy(1)
      dimension evp(npt,1),prc(npt,1),rlh(npt,1),abw(npt,1)
      dimension flx(1)
      dimension t(npt,1),tr(npt,1,1),ftr(npt,1,1),hm(npt,1)
      dimension iox(npt),nzi(npt)
      dimension tpf(npt,1)

      pi = asin(1.)*2.
      
      rlambda = 12.43*365.*24.*3600.
      decay_term = exp(-dt*alog(2.)/rlambda) - 1.
      decay_term = decay_term/dt

c                               Find year in W&R data which corresponds
c                                         to model year
c                                 [note: eventually I should interpolate
c                                        between W&R annual mean values]

      if ((iforc_tr.eq.61 .or. iforc_tr.eq.62).or.
     &          (iforc_tr.eq.63 .and. juljar.lt.1960)) then         
         nin=0
         do n=1,newr
            if (juljar .eq. nint(souryr(n))) nin=n
         enddo
      endif

c                             i/o stuff for evap,precip,relhum

      if (iforc_tr.eq.62 .or. iforc_tr.eq.63) then
         call it_catch(nevap,tdoney,nstep,it1,it2,tscl)
         if (it2.ne.idoney) then
            idoney=it2
            do i=1,npt
               prc(i,1)=prc(i,2)
               evp(i,1)=evp(i,2)
               rlh(i,1)=rlh(i,2)
               abw(i,1)=abw(i,2)
            enddo
            call read_zt(idf_donprcp,lprecip,npt,1,it2,'precip',
     &               tpf,prc(i,2))
            call read_zt(idf_donevp,levap,npt,1,it2,'evap',
     &               tpf,evp(i,2))
            call read_zt(idf_donrh,lrhum,npt,1,it2,'relhum',
     &               tpf,rlh(i,2))
            call read_zt(idf_donabwn,labwn,npt,1,it2,'abswin',
     &               tpf,abw(i,2))
         endif
         do i=1,npt
               prc(i,3) = prc(i,1) + tscl*(prc(i,2)-prc(i,1))
               evp(i,3) = evp(i,1) + tscl*(evp(i,2)-evp(i,1))
               rlh(i,3) = rlh(i,1) + tscl*(rlh(i,2)-rlh(i,1))
               abw(i,3) = abw(i,1) + tscl*(abw(i,2)-abw(i,1))
         enddo
      endif

      if (iforc_tr.eq.61) then
c                               Find latitude index "jin" from W&R data
c                                    which corresponds to model's "i"
c                                    gridpoint;
c                                  [note: eventally do spatial interp.]
         do i=1,npt
            j = ((iox(i)-1)/nxp)+1
            do jj=2,jewr-1
               phitop = souphi(jj) + 2.5
               phibot = souphi(jj) - 2.5
               if (yy(j).le.phitop .and. yy(j).gt.phibot) jin=jj
            enddo         

            avsis = 0.0
            if (sousp(jin,2) .gt. 0.0) then
               avsis50 = sousp(jin,2)
            endif
            if (souphi(jin) .ge. 0.0) then
               cp(i) = cp50n(nin)*avsis50
            else
               cp(i) = cp50s(nin)*avsis50*ss1972
            endif
            fralpha=1.12
            hrel=0.74
            fac1 = (hrel/(1.-hrel))/fralpha
            fac2 = 1./(fralpha*(1.-hrel))
            depni = (soup(jin,2) + fac1*soue(jin,2))*cp(i)
            dvni  = (sourv(jin,2)/soua(jin,2))*3.*cp(i)
            third_term = soue(jin,2)*fac2*(tr(i,1,1))
c            third_term = soue(jin,2)*fac2*(trit_offset-tr(i,1,1))
            source_term = depni + dvni - third_term

            flx(i) = source_term/hm(i,1)

c            flx(i) = 36.0/hm(i,1)

            ftr(i,1,1) = ftr(i,1,1) + flx(i)*hm(i,1)/(86400.*365.)

c            ftr(i,1,1) = ftr(i,1,1) + source_term/(86400.*365.)

         enddo
      endif

      if (iforc_tr.eq.62 .or. (iforc_tr.eq.63 .and. 
     &                     juljar.lt.1960)) then

         do i=1,npt
            j = ((iox(i)-1)/nxp)+1
            do jj=2,jewr-1
               phitop = souphi(jj) + 2.5
               phibot = souphi(jj) - 2.5
               if (yy(j).le.phitop .and. yy(j).gt.phibot) jin=jj
            enddo         

            avsis = 0.0
            if (sousp(jin,2) .gt. 0.0) then
               avsis50 = sousp(jin,2)
            endif

            if (souphi(jin) .ge. 0.0) then
               cp(i) = cp50n(nin)*avsis50
            else
               cp(i) = cp50s(nin)*avsis50*ss1972
            endif

            fralpha=1.12
            hrel=0.74

            term1 = prc(i,3)*cp(i)
            term2 = evp(i,3)*rlh(i,3)*cp(i)/(fralpha*(1.-rlh(i,3)))
            term3 = evp(i,3)*(tr(i,1,1))/(fralpha*(1.-rlh(i,3)))
c            term3 = evp(i,3)*(tr(i,1,1)-trit_offset)/(fralpha*(1.-rlh(i,3)))
            source_term = term1 + term2 - term3
       
            trtflx1(i) = term1/hm(i,1)
            trtflx2(i) = term2/hm(i,1)
            trtflx3(i) = term3/hm(i,1)
            flx(i) = trtflx1(i) + trtflx2(i) - trtflx3(i)

c            flx(i) = 36.0/hm(i,1)

            ftr(i,1,1) = ftr(i,1,1) + hm(i,1)*flx(i)/(86400.*365.)
c            ftr(i,1,1) = ftr(i,1,1) + source_term/(86400.*365.)
         enddo
      endif

      if (iforc_tr.eq.63 .and. juljar.ge.1960) then

         ndonin = 0
         do n=1,nedon
            idonyr = nint(donyr(n)-0.5)
            if (juljar .eq. idonyr) ndonin = n
         enddo
         decyr = rjuljar - real(juljar)
         fralpha = 1.12
         do i=1,npt
            cp(i)=donf1(i)*cptdon(ndonin,1)+donf2(i)*cptdon(ndonin,2)
            cp(i)=cp(i)*(1.+donam(i)*cos(2.*pi*(decyr-donphz(i))))

            term1 = prc(i,3)*cp(i)
            term2 = evp(i,3)*cp(i)*rlh(i,3)/(fralpha*(1.-rlh(i,3)))
            term3 = evp(i,3)*(tr(i,1,1))/(fralpha*(1.-rlh(i,3)))
c            term3 = evp(i,3)*(tr(i,1,1)-trit_offset)/(fralpha*(1.-rlh(i,3)))
            source_term = term1 + term2 - term3

            trtflx1(i) = term1/hm(i,1)
            trtflx2(i) = term2/hm(i,1)
            trtflx3(i) = term3/hm(i,1)
            flx(i) = trtflx1(i) + trtflx2(i) - trtflx3(i)

c            flx(i) = 36.0/hm(i,1)

            ftr(i,1,1) = ftr(i,1,1) + hm(i,1)*flx(i)/(86400.*365.)

c            ftr(i,1,1) = ftr(i,1,1) + source_term/(86400.*365.)
         enddo
      endif

c                                       AIR-SEA EXCHANGE
c                                       from Christoph's subroutine
c                                             "gasexc2.F"
c                                       Follows equations in Wanninkhof
c                                              JGR 1992
       do i=1,npt
          tcel = t(i,1)
          tcel2 = tcel*tcel
          tcel3 = tcel*tcel2
          asea  = 410.14
          bsea  = 20.503
          csea  = 0.53175
          dsea  = 0.0060111
          scsea = asea-bsea*tcel+csea*tcel2-dsea*tcel3
c...eq (1) in wanninkhof (1992) cm/hr
          rk(i) = 0.39*5.**2/sqrt(scsea/660.)
c          rk(i) = 0.39*abswin(i)**2/sqrt(scsea/660.)
c...convert to m/second
          rk(i) = rk(i)/(100.*3600.)
          term = rk(i)*tr(i,1,2)
          ftr(i,1,2) = ftr(i,1,2) -term
       enddo

c                                       RADIOACTIVE DECAY
      do i=1,npt
         do k=1,nzi(i)
             trit_sink = -hm(i,k)*tr(i,k,1)*decay_term
             ftr(i,k,1) = ftr(i,k,1)-trit_sink
             ftr(i,k,2) = ftr(i,k,2)+trit_sink
c             dcdt = decay_term*tr(i,k,1)/dt
c             term2 = hm(i,k)*dcdt
c             ftr(i,k,1) = ftr(i,k,1)+term2
c             ftr(i,k,2) = ftr(i,k,2)-term2
          enddo
      enddo


      return
      end

c--------------------------------------------------
      subroutine force2_tritium(npt,nz,ntrac,nstep,nzi,ftr,tr,hm,flx)
c--------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_tracer.h'
      dimension nzi(npt)
      dimension flx(1)
      dimension tr(npt,nz,ntrac),ftr(npt,nz,ntrac),hm(npt,nz)


c                                       for the following example,
c                                                 fake=3.0
c                                       (units: TU m/yr)
c                                       means that a ten meter layer will
c                                       increase its tritium concentration 
c                                       by 0.3 units over one year
c                                        
      fake_flux = 36.5
      do i=1,npt
         flx(i) = fake_flux
            ftr(i,1,1) = ftr(i,1,1) + flx(i)/(86400.*365.)
      enddo

c      do i=1,npt
c         flx(i) = 36.0
c         do k=1,nzi(i)
c            ftr(i,k,1) = ftr(i,k,1) + hm(i,1)*flx(i)/(86400.*365.)
c         enddo
c      enddo

c      do i=1,npt
c         flx(i) = 36.0
c         ftr(i,1,1) = ftr(i,1,1) + hm(i,1)*flx(i)/(86400.*365.)
c      enddo

      return
      end

c------------------------------------------------------------
      subroutine force_tracer(npt,nz,ntrac,nstep,nx,ny,iv_bot,
     &           rjuljar,juljar,dnt,
     &           nzi,tr,ftr,t,h,
     &           sal,yy,iox,tpf)
c------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_tracer.h'
      include 'comm_pbl.h'

      dimension tr(npt,nz,ntrac),ftr(npt,nz,ntrac)
      dimension h(npt,nz),t(npt,nz),sal(npt,nz),yy(ny)
      dimension nzi(npt)
      dimension iox(npt)
      dimension flux(100),depth(100),term(100)
      dimension tpf(1)

      parameter (factor = 0.5)
      parameter (secpmonth = 30.*24.*3600.)
      parameter (tau = secpmonth)
      parameter (tau_year = 1./(24.*365.*3600.))

c      parameter (factor_c14 = 1./(24.*3600.*365.*7.5))
      parameter (factor_age = 1./(24.*3600.*365.))
      parameter (secpyr = 24.*3600.*365.)

      parameter (trstar = 1.0)
      parameter (factor_10day  = 1/(10.*86400.))
      parameter (factor_1month = 1/((365./12.)*86400.))

c          Converting to indices for X/Y position:
c              j = ((iox(k)-1)/nx) + 1
c              i = iox(k) - (j-1)*nx


c                                           WINDSPEED-DEPENDENT
c      write(*,*) nstep,iforc_tr,npt,tr(500,1,1)

      if (iforc_tr.eq.1) then
c         call it_catch2(nt_tratm,tr_tgrid,nstep,it1,it2,clm_tscl)
         call it_catch(nt_tratm,tr_tgrid,nstep,it1,it2,clm_tscl)

         do i=1,npt
            j = ((iox(i)-1)/nx) + 1
            if (yy(j) .le. -20) then
               ilat = 1
            elseif ((yy(j) .le. 20.).and.(yy(j).gt.-20.)) then
               ilat = 2
            elseif (yy(j) .gt. 20.) then
               ilat = 3
            endif
            call val_interp(i,npt,ny,nlat_tratm,nt_tratm,ilat,it1,it2,
     &            tr_atm,val_forw,val_back,yy)
            atm_val = val_back + clm_tscl*(val_forw - val_back)
            atm_val = 0.1*atm_val + 100.0
            term_mult = 1.75/secpyr

c            call get_windspeed(npt,i,wnsp,wnsp_scalar)

            ftr(i,1,1) = ftr(i,1,1) 
c     &             +  term_mult*(wnsp_scalar-2.)*(atm_val - tr(i,1,1))
     &              +  term_mult*(wnsp(i,1)-2)*(atm_val - tr(i,1,1))
         enddo
      endif


c                                          CONSTANT WINDSPEED
      if (iforc_tr.eq.2) then
         call it_catch(nt_tratm,tr_tgrid,nstep,it1,it2,clm_tscl)
         do i=1,npt
            j = ((iox(i)-1)/nx) + 1
            if (yy(j) .le. -20) then
               ilat = 1
            elseif ((yy(j) .le. 20.).and.(yy(j).gt.-20.)) then
               ilat = 2
            elseif (yy(j) .gt. 20.) then
               ilat = 3
            endif
            call val_interp(i,npt,ny,nlat_tratm,nt_tratm,ilat,it1,it2,
     &            tr_atm,val_forw,val_back,yy)
            atm_val = val_back + clm_tscl*(val_forw - val_back)
            atm_val = 0.1*atm_val + 100.0

            ftr(i,1,1) = ftr(i,1,1) + 50.*(atm_val -tr(i,1,1))*factor_c14
         enddo
      endif

      if (iforc_tr.eq.3) then
         atm_val = 130.
         do i=1,npt
            ftr(i,1,1) = ftr(i,1,1) + 50.*(atm_val-tr(i,1,1))*factor_c14
         enddo
      endif

      if (iforc_tr.eq.4) then
         atm_val = 100.
         do i=1,npt
            ftr(i,1,1) = ftr(i,1,1) + 50.*(atm_val-tr(i,1,1))*factor_c14
         enddo
      endif

c                                           F11-WINDSPEED/SOLUBILITY
      if (iforc_tr.eq.21) then
         call it_catch(nt_tratm,tr_tgrid,nstep,it1,it2,clm_tscl)
         do i=1,npt
            j = ((iox(i)-1)/nx) + 1
            if (yy(j) .lt. 0) then
               ilat = 2
            elseif (yy(j) .ge. 0.) then
               ilat = 1
            endif
            call val_interp(i,npt,ny,nlat_tratm,nt_tratm,ilat,it1,it2,
     &            tr_atm,val_forw,val_back,yy)
            atm_val = val_back + clm_tscl*(val_forw - val_back)

c            atm_val = 100.0

            salty = sal(i,1)
            windy = 5.0
c            windy = wnsp(i)
            tempy = t(i,1)

            tempk = tempy + 273.15
            f1 = tempk/100.
            f2 = 100./tempk
            term1a = f11_a1 + f11_a2*f2 + f11_a3*log(f1) + f11_a4*f1*f1
     &           + salty*(f11_b1 + f11_b2*f1 + f11_b3*f1*f1)
            term1b = exp(term1a)
            cstar = atm_val*term1b

            sc_f11 = 4039.8 - tempy*264.7 + tempy*tempy*8.2552
     &           - tempy*tempy*tempy*0.10359
            term2 = (sc_f11/660.)**(-0.5)
c                                        piston velocity (cm/hr)
            vel_pist = 0.39*windy*windy*term2
c                                        piston veloctiy (m/s)
            vel_pist = vel_pist/3.6e5

            ftr(i,1,1) = ftr(i,1,1) + vel_pist*(cstar - tr(i,1,1))

c            ftr(i,1,1) = ftr(i,1,1) + 50.*(1.0 - tr(i,1,1))/(30.*24.*3600.)
         enddo
      endif

c                                           F12-WINDSPEED/SOLUBILITY
      if (iforc_tr.eq.22) then
         call it_catch(nt_tratm,tr_tgrid,nstep,it1,it2,clm_tscl)
         do i=1,npt
            j = ((iox(i)-1)/nx) + 1
            if (yy(j) .lt. 0) then
               ilat = 2
            elseif (yy(j) .ge. 0.) then
               ilat = 1
            endif
            call val_interp(i,npt,ny,nlat_tratm,nt_tratm,ilat,it1,it2,
     &            tr_atm,val_forw,val_back,yy)
            atm_val = val_back + clm_tscl*(val_forw - val_back)

c            atm_val = 100.0


            salty = sal(i,1)
            windy = 5.0
c            windy = wnsp(i)
            tempy = t(i,1)

            tempk = tempy + 273.15
            f1 = tempk/100.
            f2 = 100./tempk
            term1a = f12_a1 + f12_a2*f2 + f12_a3*log(f1) + f12_a4*f1*f1
     &           + salty*(f12_b1 + f12_b2*f1 + f12_b3*f1*f1)
            term1b = exp(term1a)
            cstar = atm_val*term1b

            sc_f12 = 4039.8 - tempy*264.7 + tempy*tempy*8.2552
     &           - tempy*tempy*tempy*0.10359
            term2 = (sc_f12/660.)**(-0.5)
c                                        piston velocity (cm/hr)
            vel_pist = 0.39*windy*windy*term2
c                                        piston veloctiy (m/s)
            vel_pist = vel_pist/3.6e5

            ftr(i,1,1) = ftr(i,1,1) + vel_pist*(cstar - tr(i,1,1))

         enddo
      endif

      if (iforc_tr .eq. 51) then
         mz=nz
         if (iv_bot .eq. 4) mz = nz-1

         do i=1,npt
            tr(i,1,1) = 0.0
            ftr(i,1,1) = 0.0
         enddo

         do i=1,npt
            do k=2,nzi(i)
c                                                AGE in YEARS
               ftr(i,k,1) =  ftr(i,k,1) + factor_age*h(i,k)
            enddo
         enddo
      endif
      


c
c                                                 TRITIUM FORCING
c
      if (iforc_tr.ge.61 .and. iforc_tr.le.63) then
         mz=nz
         if (iv_bot .eq. 4) mz= nz-1

c         call force_tritium2(npt,mz,ntrac,nstep,nzi,ftr,tr,h,trtflx)

         call force_tritium(npt,nz,ntrac,nstep,nx,ny,dnt,
     &         juljar,rjuljar,nzi,
     &         yy,t,evap,precip,relhum,abswin,trtflx,tr,ftr,h,iox,tpf)

      endif
c
c                                                 LU AND MCCREARY TRACER
c      
      if (iforc_tr. eq. 71) then
         do i=1,npt
            do k=1,nzi(i)
               j = (iox(i)-1)/nx + 1
               if (abs(yy(j)) .ge. 18.0) then
                  ftr(i,k,1)=ftr(i,k,1)+50.*(trstar-tr(i,k,1))*factor_1month
               endif
            enddo
         enddo
      endif

      if (iforc_tr .eq. 72) then
         mz = nz
         if (iv_bot .eq. 4) mz=nz-1
         do k=1,mz
            do i=1,npt
               j = (iox(i)-1)/nx + 1
               if (yy(j) .ge. 18.0) then
                  ftr(i,k,1)=ftr(i,k,1)+50.*(trstar-tr(i,k,1))*factor_1month
               endif
               if (yy(j) .le. -18.0) then
                  ftr(i,k,2)=ftr(i,k,2)+50.*(-trstar-tr(i,k,2))*factor_1month
               endif
            enddo
         enddo
      endif

      if (iforc_tr .eq. 73) then
         mz = nz
         if (iv_bot .eq. 4) mz=nz-1
         do k=1,mz
            do i=1,npt
               j = (iox(i)-1)/nx + 1
               if (yy(j) .ge. 18.0) then
                  ftr(i,k,1)=ftr(i,k,1)+50.*(trstar-tr(i,k,1))*factor_1month
               endif
               if (yy(j) .le. -18.0) then
                  ftr(i,k,2)=ftr(i,k,2)+50.*(trstar-tr(i,k,2))*factor_1month
               endif
               if (yy(j) .ge. 45.0) then
                  ftr(i,k,3)=ftr(i,k,3)+50.*(trstar-tr(i,k,3))*factor_1month
               endif
            enddo
         enddo
      endif

      if (iforc_tr .eq. 74) then
         do i=1,npt
            do k=2,nzi(i)
               j = (iox(i)-1)/nx + 1
               if (yy(j) .ge. 18.0) then
                  ftr(i,k,1)=ftr(i,k,1)+50.*(trstar-tr(i,k,1))*factor_1month
               endif
               if (yy(j) .le. -18.0) then
                  ftr(i,k,2)=ftr(i,k,2)+50.*(trstar-tr(i,k,2))*factor_1month
               endif
               if (yy(j) .ge. 45.0) then
                  ftr(i,k,3)=ftr(i,k,3)+50.*(trstar-tr(i,k,3))*factor_1month
               endif
            enddo
         enddo
         do i=1,npt
            tr(i,1,4) = 0.0
            ftr(i,1,4) = 0.0
         enddo
         do i=1,npt
            do k=2,nzi(i)
               ftr(i,k,4) =  ftr(i,k,4) + factor_age*h(i,k)
            enddo
         enddo
      endif

      return
      end

c------------------------------------------------------------
      subroutine get_windspeed(npt,i,wind,wnsp_scalar)
c------------------------------------------------------------
      real wind(npt)

c      write(*,*) " within get_windspeed: "
c      write(*,*) " npt= ", npt
c      write(*,*) " i= ", i
c      write(*,*) " wind(1)= ", wind(1)

      wnsp_scalar = wind(i)

c      write(*,*) " wnsp_scalar= ", wnsp_scalar
      
      return
      end
      

c------------------------------------------------------------
      subroutine val_interp(i,npt,nyp,nlat_tratm,nt_tratm,ilat,it1,it2,
     &        tr_atm,val_forw,val_back,yy)
c------------------------------------------------------------
      real tr_atm(nlat_tratm,nt_tratm)
      real yy(nyp)
      
      val_forw = tr_atm(ilat,it2)
      val_back = tr_atm(ilat,it1)

c      if (i.eq.2000) then
c         write(*,*) " w/i val_interp: "
c         write(*,*) "     i= ", i
c         write(*,*) "     val_forw= ", val_forw
c         write(*,*) "     val_back= ", val_back
c         write(*,*) "     npt= ", npt
c         write(*,*) "     nyp= ", nyp
c         write(*,*) "     nlat_tratm= ", nlat_tratm
c         write(*,*) "     nt_tratm= ", nt_tratm
c         write(*,*) "     ilat= ", ilat
c         write(*,*) "     it1= ", it1
c         write(*,*) "     it2= ", it2
c      endif

      return
      end
dyn_xir.f/      849547178   1572  1572  100444  37342     `
c***********************************************************************
c
c     routines for irregular geometry.
c
c***********************************************************************
c     ------------------------------------------------------------------
      subroutine bndrys(npt,iox,ioy,isxk,isyk,mask,h,nzi,
     *            ixk,iyk,lxxk,lyyk,lxyk,lyxk,snxk,snyk,lok,
     *            lpbcwk,lpbcek,ifxk,ifpxk,ifyk,dept)
c     ------------------------------------------------------------------
c     finds the indices of the land-ocean boundary grid points.
c
c     from the common block grid:
c     nxp,nyp = (input) # of grid points in the x and y directions.
c     nxyc    = (input) # of ocean grid points.
c     mxbdy = (input) maximum storage space for each array lxx, lyy.
c     maxnb = (input) max storage space for each array lxy, lyx, snx, sny.
c     iox   = (output) nxyc indices of the x-sorted ocean grid points.
c     ioy   = (output) nxyc indices of the ocean points for a y-sort.
c     isx   = (output) nxyc indices to gather data to the compressed
c             x-sort from the compressed y-sort.
c        isy = nxyc indices to gather data to the compressed y-sort
c              from the compressed x-sort.
c        lxx = MINSEG*(nbx+ncs) indices of points on and next to x-bndrys
c              for the compressed x-sort.
c        lyy = MINSEG*(nby+ncs) x-sort indices of points on and next 
c              to y-bndrys for the compressed y-sort.
c        lxy = nbx+ncs indices of x-boundary points for the compressed
c              y-sort.
c        lyx = nby+ncs indices of y-boundary points for the compressed
c              x-sort.
c
c     snx = (output) nbx+ncs signs (+1. or -1.) associated with the
c           x-boundary indices in lxx.  if snx(i)=1., then the ocean
c           grid point with index lxx(i) is to the east (pos. x-dir.)
c           of the adjacent land point.  if snx(i)=-1.,
c           then the ocean pt. lxx(i) is to the west (neg. x-dir) of
c           the adjacent land grid point.
c     sny = (output) nby+ncs signs (+1. or -1.) associated with the
c           y-boundary indices in lyy in the same since as snx and lxx.
c     nbx = (output) # of x-boundary grid points.
c     nby = (output) # of y-boundary grid points.
c     ncs = (output) # of interior corner boundary grid points.
c
c     *****************************************************************
c     a few words about the different data sorts and bndry indices:
c
c        the boundary grid points are the ocean grid points which are
c     adjacent to one or more land grid points.  an ocean point is an
c     x-boundary point if the adjacent land point is in the pos. or neg.
c     x-direction, and an ocean point is a y-boundary pt if the adjacent
c     land point is in the pos. or neg. y-direction.  thus a point
c     can be both an x-boundary and a y-boundary point.  there are nbx
c     and nby x and y boundary points, respectively.  a special case is
c     an ocean point which is neither an x nor a y boundary point,
c     but is adjacent to a land point in a diagonal direction.  these are
c     referred to as interior corner boundary points (there are always
c     some on a peninsula).  there are ncs ocean points of this type.
c
c        assume that a data field is stored in the matrix u(i,j) whose
c     first dimension has been declared as nxp elements.  the index i
c     corresponds to increasing x, and j corresponds to increasing y.  in
c     fortran, the elements of u are stored sequentially with the index
c     i increasing before j, ie. u(1,1),u(2,1),...,u(nxp,1),u(1,2),...
c     this is the x or regular x-sort.  the y or regular y-sort is simply
c     a sequential storage of u with the j index increasing before i,
c     u(1,1),u(1,2),...,u(1,nyp),u(2,1),u(2,2),.... the compressed
c     x-sort is the regular x-sort, excluding land points.  the elements
c     representing ocean points are simply shifted towards u(1,1) to
c     fill the gaps left by the land elements, so that all ocean points
c     are stored consecutively.  similarly, the compressed y-sort is the
c     regular y-sort, excluding land points.
c        for each type of sort the data u can obviously be identified by
c     a single index, say k.  if k is simply the sequential position of
c     the element as it is stored, then for the regular sorts, k can be
c     expressed in terms of the original indices i and j:
c        k = i + (j-1)*nxp       regular x-sort
c        k = j + (i-1)*nyp       regular y-sort
c     the indices iox are the k-indices of the ocean pts for an x-sort
c     and the indices ioy are the k-indices of the ocean pts for a
c     regular y-sort.  some relations between sorts and indices are:
c        uxc(i) = ux(iox(i))   compressed x-sort from regular x-sort
c        uyc(i) = uy(ioy(i))   compressed y-sort from regular y-sort
c        uyc(i) = uxc(isy(i))  compressed y-sort from compressed x-sort,
c                               where isy is a columnwise ordering of the
c                               compressed x-sort indices
c        uxc(i) = uyc(isx(i))  compressed x-sort from compressed y-sort,
c                               where isx is a rowwise ordering of the
c                               compressed y-sort indices
c        isx(isy(k)) = k, and isy(isx(k)) = k
c
c        the k-index for the regular x-sort can be expressed in terms 
c     of the k-index for the regular y-sort, and vice versa.  so the
c     indices of ocean grid points in the two sorts are related as:
c           ioy(i) = ((iox(i)-1)/nxp)*(1-nxp*nyp) + (iox(i)-1)*nyp + 1
c     and
c           iox(i) = ((ioy(i)-1)/nyp)*(1-nxp*nyp) + (ioy(i)-1)*nxp + 1
c
c     (the divisions must operate on integers)
c
c     *****************************************************************
      implicit real(a-h,o-z),integer(i-n)
c
      include 'comm_para.h'
      dimension isx(1),isy(1),iox(1),ioy(1),h(1)

      dimension ixk(npt,nz),iyk(npt,nz),isxk(npt,nz),isyk(npt,nz),
     +          lxxk(MXBDY,nz),lyyk(MXBDY,nz),lxyk(MAXNB,nz),lyxk(MAXNB,nz),
     +          snxk(MAXNB,nz),snyk(MAXNB,nz), mask(nxp*nyp,nz), dept(npt),
     +          ifxk(9*MAXSID,nz),ifpxk(5*MAXSID,nz),ifyk(9*MAXSID,nz),
     +          lpbcwk(MAXSID,nz),lpbcek(MAXSID,nz),lok(4*MAXSID,nz),nzi(npt)

      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +            ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)
      common /new_filt/  MAXFO, nxk, nyk, nfx, nfpx, nfy
c
      if (MINSEG.le.0 .or. nxp.le.0 .or. nyp.le.0) return

      nptk(1) = npt

c.....iox and mask have already been created for top level, here we
c.....initialize mask for rest of levels
      call maskk (npt,nxp,nyp,nz,nzi,iox,mask)

c.....get the nbx x-bndry and the nby y-bndry indices
      call bndxy (npt,iox,ioy,lxxk,lyyk,lxyk,lyxk,snxk,snyk,
     *            isxk,isyk,lpbcwk,lpbcek,mask,nzi,h,ixk,iyk,lok,dept)
      
c.....compute indices for shapiro filters
      do k = 1, nz
         call shap_indx (nptk(k),nxp,nyp,mask(1,k),isxk(1,k),
     *            nfxk(k),nfpxk(k),nfyk(k),ifxk(1,k),ifpxk(1,k),ifyk(1,k))
      enddo
      
c.....find the ncs interior-corner indices for the compressed x-sort.
c.....store them at the end of lxx, and store the signs in snx.
      do k = 1, nz
         ncx = nbxk(k)
         ncy = nbyk(k)
         call newcorn (nxp,nyp,ncsk(k),lxxk(ncx+1,k),snxk(ncx+1,k),
     *                 lyyk(ncy+1,k),snyk(ncy+1,k),mask(1,k),isxk(1,k))
      enddo

      need = MINSEG*(max0(nbx,nby)+ncs)
      if (need .gt. MXBDY) call wspace('MXBDY', need)

c.....store copies of the corner indices for both sorts in lyx and lxy.
      do k = 1, nz
         ncx = nbxk(k)
         ncy = nbyk(k)
         do i = 1, ncsk(k)
            lyxk(ncy+i,k) = lxxk(ncx+i,k)
            lxyk(ncx+i,k) = lyyk(ncy+i,k)
         enddo
      enddo
c

      do k = 1, nz
         nc = ncsk(k)
         ncx = nbxk(k)
         ncy = nbyk(k)
         nbxc = ncx + nc
         nbyc = ncy + nc
         do m = 1, MINSEG - 1
            do i = 1, ncx
               lxxk(m*nbxc+i,k) = lxxk(i,k) + isign(m, int(snxk(i,k)))
            enddo
            do i = 1, ncy
               lyyk(m*nbyc+i,k) = lyyk(i,k) + isign(m, int(snyk(i,k)))
            enddo
         enddo
         
         do i = 1, nc
            lxxk(nbxc+i+ncx,k) = lxxk(i+ncx,k) + isign(1, int(snxk(i+ncx,k)))
            lyyk(nbyc+i+ncy,k) = lyyk(i+ncy,k) + isign(1, int(snyk(i+ncy,k)))
         enddo
      enddo


c  now combine a few of the mappings:

      do k = 1, nz
         npk = nptk(k)
         do i = 1, npk
            if (isyk(i,k).lt.1.or.isyk(i,k).gt.npt) print*,'trouble',i,k
            isyk(i,k) = ixk(isyk(i,k),k)
         enddo
         nbyck = nbyk(k) + ncsk(k)
         nbxck = nbxk(k) + ncsk(k)
         do i = 1, MINSEG*nbyck
            ly = lyyk(i,k)
            if (ly.le.npk.and.ly.ge.1) lyyk(i,k) = isyk(ly,k)
         enddo
         do i = 1, nbxck
            ly = lxyk(i,k)
            if (ly.le.npk.and.ly.ge.1) lxyk(i,k) = isyk(ly,k)
         enddo
         do i = 1, MINSEG*nbxck
            ly = lxxk(i,k)
            if (ly.le.npk.and.ly.ge.1) lxxk(i,k) = ixk(ly,k)
         enddo
         do i = 1, nbyck
            ly = lyxk(i,k)
            if (ly.le.npk.and.ly.ge.1) lyxk(i,k) = ixk(ly,k)
         enddo
         do i = 1, npbck(k)
            ly = lpbcek(i,k)
            if (ly.le.npk.and.ly.ge.1) lpbcek(i,k) = ixk(ly,k)
            ly = lpbcwk(i,k)
            if (ly.le.npk.and.ly.ge.1) lpbcwk(i,k) = ixk(ly,k)
         enddo
         do i = 1, nlok(k)
            ly = lok(i,k)
            if (ly.le.npk.and.ly.ge.1) lok(i,k) = ixk(ly,k)
         enddo
      enddo

      return
c     end of bndrys.
      end

c------------------------------------------------------------------
      subroutine bndxy(npt,iox,ioy,lxx,lyy,lxy,lyx,snx,sny,
     +                 isxk,isyk, lpbcw, lpbce, mask, nzi,h,ixk, iyk, lok, dept)
c------------------------------------------------------------------
c     Get the compressed x-sort boundary indices.  
c     iox    = (input) nxyc indices of the ocean points for the x-sort.
c     maxnb  = (input) max. storage space for lxx, lyy, lxy, or lyx.
c            = default maximum allowable value for max0(nbx,nby).
c     minseg = (input) required minimum # of consecutive ocean points
c              interior to and including each boundary point.
c     lxx    = (output) x-bndry indices for the compressed x-sort.
c     lyy    = (output) y-bndry indices for the compressed y-sort.
c     lxy    = (output) x-bndry indices for the compressed y-sort.
c     lyx    = (output) y-bndry indices for the compressed x-sort.
c     snx    = (output) nbx signs for the x-boundaries.
c     sny    = (output) nby signs for the y-boundaries.
c     ioy    = (output) nxyc indices of the ocean points for the y-sort.
c     isx    = (output) nxyc indices to gather the compressed x-sort
c              from the compressed y-sort.
c     isy    = (output) nxyc indices to gather the compressed y-sort
c              from the compressed x-sort.
c
      implicit real(a-h,o-z),integer(i-n)
      include 'comm_new.h'
      include 'comm_para.h'
      dimension iox(1),ioy(1),isxk(npt,nz),isyk(npt,nz),
     +          lxx(MXBDY,nz),lyy(MXBDY,nz),lxy(MAXNB,nz),lyx(MAXNB,nz),
     +          snx(MAXNB,nz),sny(MAXNB,nz), mask(nxp*nyp,nz), nzi(npt),
     +          h(1),lpbcw(MAXSID,nz),lpbce(MAXSID,nz),lok(4*MAXSID,nz),
     +          ixk(npt,nz),iyk(npt,nz), dept(npt)
      common/grid/nxp,nyp,nxyc,nz,nbx,nby,ncs,land,nlo,npbc
      common/gridk/nptk(MAXNZ),nbxk(MAXNZ),nbyk(MAXNZ),ncsk(MAXNZ)
     +         ,npbck(MAXNZ),nlok(MAXNZ),nfxk(MAXNZ),nfpxk(MAXNZ),nfyk(MAXNZ)

c.....convert the x-sort indices in iox to y-sort indices ioy.
      nxy1 = 1-nxp*nyp
c
c.....convert cumulation location of ocean points from rowwise to
c.....colomnwise.

      do i=1,nxyc
         ioy(i) = ((iox(i)-1)/nxp)*nxy1 + (iox(i)-1)*nyp + 1
      enddo

c     sort by increasing value so that ioy(1) is the bottom of the
c     first ocean column and not the beginning of the first ocean
c     row.  the sort order is isy.

      call sorti(nxyc,ioy,1,isyk)

c     form isxk from isyk, i.e. find the rowwise ordering of the
c     compressed y-sort indices.

      do i=1,nxyc
         isxk(isyk(i,1),1) = i
      enddo

c.....find x-bndry indices for the compressed x-sort.
      do i=1,nxyc
         ixk(i,1) = i
         iyk(i,1) = i
      enddo

      if (iglob .eq. 0) then
         call bound(nxyc,iox,ixk,nxp,maxnb,minseg,nbxk,lxx,snx)
      else
         call set_pbc (nxp,nyp, npbck, lpbcw, lpbce, mask)
         call set_bpx (nxp,nyp,mask,maxnb,minseg,nbxk,lxx,snx)
      endif

      call reset_mask (nxyc,nxp,nyp,nz,nzi,h,mask,MINSEG,nptk,
     *                 ixk,iyk,isxk,isyk,dept)
      do k = 2, nz
         do i=1,nptk(k)
            isxk(isyk(i,k),k) = i
         enddo
      enddo

      call make_lok(npt,nxp,nyp,nz,iox,mask,nlok,lok)

      do k = 2, nz
         npbck(k) = 0
         if (iglob .eq. 0) then
            call bound(nptk(k),iox,ixk(1,k),nxp,maxnb,minseg,
     *                 nbxk(k),lxx(1,k),snx(1,k))
         else
            call set_pbck (nxp,nyp,npbck(k),lpbcw(1,k),lpbce(1,k),
     *                     mask(1,k))
            call set_bpxk (nxp,nyp,mask(1,k),nbxk(k),lxx(1,k),snx(1,k))
         endif
      enddo

      do k = 1, nz

c.....find y-bndry indices for the compressed y-sort.
         call bound(nptk(k),ioy,iyk(1,k),nyp,maxnb,minseg,
     *              nbyk(k),lyy(1,k),sny(1,k))

c        find the y-bndry indices for the compressed x-sort using the
c        columnwise ordering of the compressed x-sort.
         do i=1,nbyk(k)
            lyx(i,k) = isyk(lyy(i,k),k)
         enddo

c     sort in sequential order.
         call sorti(nbyk(k),lyx(1,k),0)

      enddo

c     find the x-bndry indices for the compressed y-sort using the
c     rowwise ordering of the compressed x-sort.

      do k = 1, nz
         do i=1,nbxk(k)
            lxy(i,k) = isxk(lxx(i,k),k)
         enddo
         
         call sorti(nbxk(k),lxy(1,k),0)

      enddo

      return
c     end of bndxy.
      end
c
c     ------------------------------------------------------------------
      subroutine bound(npk,ioc,ixk,nsid,maxnb,minseg,nb,lbn,sgn)
c     ------------------------------------------------------------------
      implicit real(a-h,o-z),integer(i-n)
      character*72 msg
      dimension ioc(1),lbn(1),sgn(1),ixk(1)
c
      if (npk.eq.0) then
         nb = 0
         return
      endif

      nb = 1
      lbn(1) = 1
      sgn(1) = 1.
c
c     cycle through all ocean points and note the location of all
c     nonconsecutive indices and points at the absolute extreme of
c     the rectangular grid.
c
      do 10 i=2,npk
         ii = ixk(i)
         im = ixk(i-1)
      if(ioc(ii)-ioc(im).gt.1 .or. mod(ioc(ii)-1,nsid).eq.0) then
         if(nb+3 .gt. maxnb) goto 20
c
c        store location and set sign for the previous end of row
c        or top of column.
c
         nb = nb + 1
         lbn(nb) = i - 1
         sgn(nb) = -1.
c
c        make sure the boundary geometry will permit a 4th order
c        differencing.
c
         if(lbn(nb)-lbn(nb-1)+1 .lt. minseg) goto 30
c
c        store location and set sign for the start of row or bottom
c        of column.
c
         nb = nb + 1
         lbn(nb) = i
         sgn(nb) = 1.
      endif
   10 continue
c
c     register last point.
c
      nb = nb + 1
      lbn(nb) = npk
      sgn(nb) = -1.
      if(lbn(nb)-lbn(nb-1)+1 .lt. minseg) goto 30
      return
   20 write(msg,21) maxnb
   21 format('bound: insufficient space for lb.  maxnb=',i10,'$')
      call perror1(msg,1)
   30 j = (ioc(lbn(nb))-1)/nsid + 1
      i = ioc(lbn(nb)) - (j-1)*nsid
      write(msg,31) lbn(nb)-lbn(nb-1)+1,i,j
   31 format('bound: only',i3,' consecutive ocean grid pts',
     +       ' near (i,j or j,i)= ',2i5,'$')
      call perror1(msg,1)
c     end of bound.
      end

c     ------------------------------------------------------------------ 
      subroutine gridxy(nxp,nyp,x1,x2,y1,y2,nsx,nsy,nystrch,xs,alpha,beta,
     *                  x,y,xp,yp,xpp,ypp)
c     ------------------------------------------------------------------ 
c     compute the x and y grid point coordinates.
c
c     nxp,nyp = (input) # of grid points in the x and y directions.
c     x1,x2   = (input) minimum and maximum x-coordinate.
c     y1,y2   = (input) minimum and maximum y-coordinate.
c     nsx,nsy = (input) # of atan's composing the stretched grid
c               transformation function for the x and y directions.
c     xs      = (input) locations of the atan's for x: xs(1 to nsx),
c               and for y: xs(nsx+1 to nsx+nsy).
c     alpha   = (input) parameters that will determine the # of grid
c               points in a stretched region;
c               x: alpha(1 to nsx); and for y: alpha(nsx+1 to nsx+nsy).
c     beta    = (input) parameters that determines the scale width of
c               each stretched region;
c               x: beta(1 to nsx); and for y: beta(nsx+1 to nsx+nsy).
c     x,y     = (output) nxp x and nyp y grid coordinates.
c     xp      = (output) nxp derivatives of the x-transformation
c               function: d(psi1(x))/d(x).
c     yp      = (output) nyp derivatives of the y-transformation
c               function