c
c     ****************************************************************
c     *                                                              *
c     *                      subroutine ouhrks                       *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 8/1/2103 rhd               *
c     *                                                              *
c     *     this subroutine drives the computaion of the necessary   *
c     *     stress or strain hard copy output quantities for a block *
c     *     of non-conflicting, similar elements.                    *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks( span, blk, felem, type, order,
     &                   ngp, nnode,
     &                   geonl, long, nodpts, do_stresses,
     &                   mat_type, center_output, num_short_stress,
     &                   num_short_strain )
      use global_data ! old common.main
      implicit integer (a-z)
      logical do_stresses, geonl, long, nodpts, center_output
      double precision ::  nowtime

c
c                       get the element stresses or strains
c                       into a final form.
c                       for geonl: the cauchy stresses are computed
c                       from the unrotated cauchy stresses; the
c                       strains are accumulated spatial deformation
c                       increments.
c

      matnum = iprops(38,felem)  ! common.main
      kout = out                 !   "
      nowtime = total_model_time !   "
      nowstep = ltmstp           !   "
c
      call ougts1( span, blk, felem, do_stresses, ngp,
     &             geonl, mat_type, matnum, kout, nowtime, nowstep )
c
c                       for output at element center, make
c                       all gauss points have the average values.
c
      if ( center_output ) then
        call oumkcv( span, ngp, do_stresses, num_short_stress,
     &               num_short_strain )
      end if
c
c                       extrapolate gauss point results to element
c                       nodes. the 6 primary
c                       components, energy density, mises equiv.
c                       stress and material specific output values
c                       are extrapolated from gauss points to nodes.
c
      if( nodpts ) then
         call ounds1( span, type, order, nnode, ngp,
     &                do_stresses, num_short_stress, num_short_strain )
      end if
c
c                       for strain output, compute equivalent
c                       strain. if nodal, we are using extrapolated
c                       components. for center-output, we are using
c                       the averaged components. for stress output,
c                       we get the mises equivalent stress rather than
c                       equivalement strain.
c
      op_code = 1
      call ouext1( span, do_stresses, nnode, ngp, nodpts,
     &             num_short_stress, num_short_strain, op_code,
     &             mxvl )
c
c                       compute extra element quantities for long
c                       output (invariants, principal values, directions).
c                       for nodal output, the 6 primary strain/stress
c                       components are used. for nodal output, the
c                       extrapolated gp values are being used.
c
      if ( long ) then
        call ouext1( span, do_stresses, nnode, ngp, nodpts,
     &               num_short_stress, num_short_strain, 2, mxvl )
      end if
c
      return
      end

c     ****************************************************************
c     *                                                              *
c     *                   subroutine ouhrks_link                     *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 8/20/2017 rhd              *
c     *                                                              *
c     *               drive output for a single link element         *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_link( elem, blk, felem, elem_type, num_enodes,
     &                       do_stress, mat_type, wide, eform, prec,
     &                       lnum, pgnum, lbltyp, strlbl, hedtyp,
     &                       noheader, out_packet_now, geo_non_flg  )
      use global_data ! old common.main
c
      use elblk_data, only : urcs_blk_n, elestr, ddtse
c
      implicit none
c
      integer :: elem, blk, felem, elem_type, num_enodes, mat_type,
     &           pgnum, lnum, lbltyp
      logical :: do_stress, wide, eform, prec, noheader,
     &           out_packet_now, geo_non_flg
      character(len=8) :: strlbl(30), hedtyp*30
c
c             locals
c
      integer :: nvals_to_output, bele
      logical :: newel
      logical, parameter :: local_debug = .false.
c
      if( local_debug ) write(out,9000) elem, blk, elem_type
c
      if( do_stress ) then
        nvals_to_output = 3
        elestr(1,1,1) = urcs_blk_n(1,1,1)
        elestr(1,2,1) = urcs_blk_n(1,2,1)
        elestr(1,3,1) = urcs_blk_n(1,3,1)
      else ! strain output
        nvals_to_output = 3
        elestr(1,1,1) = ddtse(1,1,1)
        elestr(1,2,1) = ddtse(1,2,1)
        elestr(1,3,1) = ddtse(1,3,1)
      end if
c
c             set labels for link element as needed.
c             then output values.
c
      call oulbst( do_stress, lbltyp, elem_type, elem, strlbl,
     &             .false., hedtyp, .false., 0 )
c
      bele  = 1
      newel = .true.
c
      call ouhel( bele, elem, hedtyp, 2, 1,
     &            .false., nvals_to_output, wide,
     &            eform, prec, strlbl, pgnum, lnum, newel,
     &            .false., noheader, out_packet_now )
c
      return

 9000 format(/,'.... entered ouhkrs_link ....',
     &  /,10x,'elem, blk, etype: ', i8, i7, i5 )
 9010 format(15x,'node1:2, x1,y1,z1:', 2i7,3f10.3,
     & /,15x,'x2,y2,z2, len0:',4f10.3,
     & /,15x,'u1,v1,w1: ',3f15.6,
     & /,15x,'u2,v2,w2: ',3f15.6 )
 9100 format(/,">>>> FATAL ERROR. oulbst_bar. val: ",i10,
     & /,      "                  job aborted...",//)
c
      end

c     ****************************************************************
c     *                                                              *
c     *                   subroutine ouhrks_bar                      *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 8/4/2017 rhd               *
c     *                                                              *
c     *               drive output for a single bar element          *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_bar( elem, blk, felem, elem_type, num_enodes,
     &                       do_stress, mat_type, wide, eform, prec,
     &                       lnum, pgnum, lbltyp, strlbl, hedtyp,
     &                       noheader, out_packet_now, geo_non_flg  )
      use global_data ! old common.main
c
      use elblk_data, only : urcs_blk_n, ddtse, elestr
      use main_data, only : incmap, incid, crdmap
c
      implicit none
c
      integer :: elem, blk, felem, elem_type, num_enodes, mat_type,
     &           pgnum, lnum, lbltyp
      logical :: do_stress, wide, eform, prec, noheader,
     &           out_packet_now, geo_non_flg
      character(len=8) :: strlbl(30), hedtyp*30
c
c             locals
c
      integer :: nvals_to_output, pos, node1, node2, bele
      double precision :: x1, x2, y1, y2, z1, z2, len0, u1, u2, v1, v2,
     &                    w1, w2, len, area
      double precision, parameter :: zero = 0.0d0
      logical :: newel
      logical, parameter :: local_debug = .false.
c
      if( local_debug ) write(out,9000) elem, blk, elem_type
c
      if( do_stress ) then  !  must get area @ n1 for geonl
        nvals_to_output = 2
        elestr(1,1,1) = urcs_blk_n(1,1,1)
        pos   = incmap(elem)
        node1 = incid(pos)
        node2 = incid(pos+1)
        x1 = c(crdmap(node1))
        y1 = c(crdmap(node1)+1)
        z1 = c(crdmap(node1)+2)
        x2 = c(crdmap(node2))
        y2 = c(crdmap(node2)+1)
        z2 = c(crdmap(node2)+2)
        len0 = sqrt( (x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2 )
        u1 = u(node1)
        u2 = u(node2)
        v1 = u(node1+nonode)
        v2 = u(node2+nonode)
        w1 = u(node1+2*nonode)
        w2 = u(node2+2*nonode)
c        if( local_debug ) write(out,9010) node1, node2, x1, y1, z1,
c     &      x2, y2, z2, len0, u1, v1, w1, u2, v2, w2
        y1 = y1 + v1
        z1 = z1 + w1
        x2 = x2 + u2
        y2 = y2 + v2
        z2 = z2 + w2
        len = sqrt( (x2-x1)**2 + (y2-y1)**2 + (z2-z1)**2 )
        area = props(43,elem)
        if( geo_non_flg ) area = area * len0 / len
        elestr(1,2,1) = urcs_blk_n(1,1,1) * area
      else ! strain output
        nvals_to_output = 1
        elestr(1,1,1) = ddtse(1,1,1)
      end if
c
c             set labels for bar element as needed. then output values.
c
      call oulbst( do_stress, lbltyp, elem_type, elem, strlbl,
     &             .false., hedtyp, geo_non_flg, 0 )
c
      bele  = 1
      newel = .true.
c
      call ouhel( bele, elem, hedtyp, 2, 1,
     &            .false., nvals_to_output, wide,
     &            eform, prec, strlbl, pgnum, lnum, newel,
     &            .false., noheader, out_packet_now )
c
      return

 9000 format(/,'.... entered ouhkrs_bar ....',
     &  /,10x,'elem, blk, etype: ', i8, i7, i5 )
 9010 format(15x,'node1:2, x1,y1,z1:', 2i7,3f10.3,
     & /,15x,'x2,y2,z2, len0:',4f10.3,
     & /,15x,'u1,v1,w1: ',3f15.6,
     & /,15x,'u2,v2,w2: ',3f15.6 )
 9100 format(/,">>>> FATAL ERROR. oulbst_bar. val: ",i10,
     & /,      "                  job aborted...",//)
c
      end
c     ****************************************************************
c     *                                                              *
c     *                subroutine ouhrks_cohesive                    *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 8/1/2013 rhd               *
c     *                                                              *
c     *     drive output for a single interface-cohesive element     *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_cohesive( elem, blk, felem, elem_type,
     1    int_order, num_int_points, num_enodes, center_output,
     2    do_stress, mat_type, cohesive_type,wide,eform,
     3    prec, lnum, pgnum, lbltyp, strlbl, hedtyp, noheader,
     4    out_packet_now, geo_non_flg  )
      use global_data ! old common.main
c
      use elblk_data, only : elem_hist, urcs_blk_n, ddtse, elestr

      implicit integer (a-z)
      logical :: do_stress, center_output, wide, eform, newel,
     &        prec, noheader, out_packet_now, geo_non_flg
      character(len=8) :: strlbl(30), hedtyp*30
c
c             locals also visible by contains
c
      double precision :: zero,  avgs(mxoupr)
      logical :: local_debug, exp_model, ppr_model
      integer :: kout
      data zero / 0.0d00 /
c
c             get the element tractions or displacement jumps
c             with suplemental values in final form for output.
c
      local_debug = .false.
      kout = out
c
      if( local_debug ) write(kout,9000) elem, blk, elem_type,
     &       num_int_points, center_output, cohesive_type
c
      avgs(1:mxoupr) = zero
c
      select case( cohesive_type )
c
      case( 1, 2, 3, 5 )
c
        if( do_stress ) then
          call ouhrks_simple_tractions
          nvals_to_output = 6
        else
          call ouhrks_simple_displ_jumps
          nvals_to_output = 4
        end if
c
      case( 4 )  ! simple exponential model
c
        if( do_stress ) then
          call ouhrks_exp1_tractions
          nvals_to_output = 8
        else
          call ouhrks_exp1_displ_jumps
          nvals_to_output = 6
        end if
c
      case( 6 )  ! ppr
c
        if( do_stress ) then
          call ouhrks_ppr_tractions
          nvals_to_output = 8
        else
          call ouhrks_ppr_displ_jumps
          nvals_to_output = 6
        end if
c
      case( 7 )  ! cavit
c
        if( do_stress ) then
          call ouhrks_cavit_tractions
          nvals_to_output = 13
        else
          call ouhrks_simple_displ_jumps
          nvals_to_output = 4
        end if
c
      case default
c
        write(out,9100) cohesive_type
        call die_abort
c
       end select
c
c             set the traction-displacement jump labels for
c             the current element. then output values.
c
      call oulbst( do_stress, lbltyp, elem_type, elem, strlbl,
     &             long, hedtyp, geo_non_flg, cohesive_type )

      bele            = 1
      newel           = .true.
c
      call ouhel( bele, elem, hedtyp, num_enodes, num_int_points,
     &            .false., nvals_to_output, wide,
     &            eform, prec, strlbl, pgnum, lnum, newel,
     &            center_output, noheader, out_packet_now )
c
      return

 9000 format(/,'.... entered ouhkrs_cohesive ....',
     &  /,10x,'elem, blk, etype, npts, cntrout, c_type: ',
     &  i8,i4,i3,i3,l3,i4 )
 9100 format(/,">>>> FATAL ERROR. oulbst_cohesive. val: ",i10,
     & /,      "                  job aborted...",//)

      contains
c     ****************************************************************
c     *                                                              *
c     *              subroutine ouhrks_cavit_tractions               *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 3/4/2015 rhd               *
c     *                                                              *
c     *     pull together traction-type output values for            *
c     *     the cavity cohesive material type                        *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_cavit_tractions
      implicit integer (a-z)
c
c             locals (see also contains main)
c
      double precision
     &   t1, t2, tn, ts, gamma, gamma_ur, n_bar, a_bar, b_bar,
     &   v_bar, criticality, max_Tn, max_Dn, omega, lambda_4,
     &   a_over_l_nr
c
      if( local_debug ) write(kout,9020)
c
      do gpn = 1, num_int_points
        t1               = urcs_blk_n(1,1,gpn)
        t2               = urcs_blk_n(1,2,gpn)
        tn               = urcs_blk_n(1,3,gpn)
        gamma            = urcs_blk_n(1,7,gpn)
        gamma_ur         = urcs_blk_n(1,8,gpn)
        ts               = sqrt( t1*t1 + t2*t2 )
        elestr(1,1,gpn)  = t1
        elestr(1,2,gpn)  = t2
        elestr(1,3,gpn)  = ts
        elestr(1,4,gpn)  = tn
        elestr(1,5,gpn)  = gamma
        elestr(1,6,gpn)  = gamma_ur
        n_bar            = elem_hist(1,1,gpn)
        a_bar            = elem_hist(1,2,gpn)
        b_bar            = elem_hist(1,3,gpn)
        lambda_4         = elem_hist(1,11,gpn)
        omega            = lambda_4 * a_bar / b_bar ! a/b
        v_bar            = elem_hist(1,4,gpn)
        criticality      = elem_hist(1,8,gpn)
        max_Tn           = elem_hist(1,9,gpn)
        max_Dn           = elem_hist(1,10,gpn)
        a_over_l_nr      = elem_hist(1,12,gpn)
        elestr(1,7,gpn)  = n_bar
        elestr(1,8,gpn)  = omega
        elestr(1,9,gpn)  = a_bar
        elestr(1,10,gpn) = criticality
        elestr(1,11,gpn) = max_Tn
        elestr(1,12,gpn) = max_Dn
        elestr(1,13,gpn) = a_over_l_nr
        avgs(1:13)     = avgs(1:13) + elestr(1,1:13,gpn)
        if( local_debug ) write(kout,9030) gpn, elestr(1,1:6,gpn)
      end do
c
      if( center_output ) then
        avgs(1:13)      = avgs(1:13) / dble( num_int_points )
        t1              = avgs(1)
        t2              = avgs(2)
        ts              = sqrt( t1**2 + t2**2 )
        tn              = avgs(4)
        gamma           = avgs(5)
        gamma_ur        = avgs(6)
        n_bar           = avgs(7)
        omega           = avgs(8)  ! a / b average over element
        a_bar           = avgs(9)
        criticality     = avgs(10) ! need to think what this means
        max_Tn          = avgs(11)
        max_Dn          = avgs(12)
        a_over_l_nr     = avgs(13)
c
        elestr(1,1,1) = t1
        elestr(1,2,1) = t2
        elestr(1,3,1) = ts
        elestr(1,4,1) = tn
        elestr(1,5,1) = gamma
        elestr(1,6,1) = gamma_ur
        elestr(1,7,1) = n_bar
        elestr(1,8,1) = omega
        elestr(1,9,1) = a_bar
        elestr(1,10,1) = criticality
        elestr(1,11,1) = max_Tn
        elestr(1,12,1) = max_Dn
        elestr(1,13,1) = a_over_l_nr
c
        if( local_debug ) write(kout,9032) elestr(1,1:6,1)
      end if
c
      return
c
 9020 format(/,"... cavity cohesive model: tractions ...",/,
     & 10x,'int pt',5x,'t1',9x,'t2',10x,'ts',10x,'tn',
     &  5x,'E(tot)',6x,'E(plas)' )
 9030 format(10x,i2,6f12.4)
 9032 format(9x,'avg',6f12.4)
c
      end subroutine ouhrks_cavit_tractions
c     ****************************************************************
c     *                                                              *
c     *              subroutine ouhrks_simple_tractions              *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 3/11/13 rhd                *
c     *                                                              *
c     *     pull together tractions output values for other          *
c     *     cohesive types                                           *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_simple_tractions
      implicit integer (a-z)
c
c             locals (see also contains main)
c
      double precision
     &   t1, t2, tn, ts, gamma, gamma_ur
c
      if( local_debug ) write(kout,9020)
c
      do gpn = 1, num_int_points
        t1       = urcs_blk_n(1,1,gpn)
        t2       = urcs_blk_n(1,2,gpn)
        tn       = urcs_blk_n(1,3,gpn)
        gamma    = urcs_blk_n(1,7,gpn)
        gamma_ur = urcs_blk_n(1,8,gpn)
        ts       = sqrt( t1*t1 + t2*t2 )
        elestr(1,1,gpn) = t1
        elestr(1,2,gpn) = t2
        elestr(1,3,gpn) = ts
        elestr(1,4,gpn) = tn
        elestr(1,5,gpn) = gamma
        elestr(1,6,gpn) = gamma_ur
        avgs(1:6)       = avgs(1:6) + elestr(1,1:6,gpn)
        if( local_debug ) write(kout,9030) gpn, elestr(1,1:6,gpn)
      end do
c
      if( center_output ) then
        avgs(1:6)       = avgs(1:6) / dble( num_int_points )
        t1              = avgs(1)
        t2              = avgs(2)
        ts              = sqrt( t1**2 + t2**2 )
        tn              = avgs(4)
        gamma           = avgs(5)
        gamma_ur        = avgs(6)
c
        elestr(1,1,1) = t1
        elestr(1,2,1) = t2
        elestr(1,3,1) = ts
        elestr(1,4,1) = tn
        elestr(1,5,1) = gamma
        elestr(1,6,1) = gamma_ur
        if( local_debug ) write(kout,9032) elestr(1,1:6,1)
      end if
c
      return
c
 9020 format(/,"... other cohesive model: tractions ...",/,
     & 10x,'int pt',5x,'t1',9x,'t2',10x,'ts',10x,'tn',
     &  5x,'E(tot)',6x,'E(plas)' )
 9030 format(10x,i2,6f12.4)
 9032 format(9x,'avg',6f12.4)
c
      end subroutine ouhrks_simple_tractions
c

c     ****************************************************************
c     *                                                              *
c     *          subroutine ouhrks_simple_displ_jumps                *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 3/11/13 rhd                *
c     *                                                              *
c     *     pull together displacement jumps output values for       *
c     *     other cohesive material type                             *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_simple_displ_jumps
      implicit integer (a-z)
c
c             locals (see also contains main)
c
      double precision
     &   d1, d2, dn, ds
c
      if( local_debug ) write(kout,9020)
c
      do gpn = 1, num_int_points
c
        d1              = ddtse(1,1,gpn)
        d2              = ddtse(1,2,gpn)
        dn              = ddtse(1,3,gpn)
        ds              = sqrt( d1*d1 + d2*d2 )
c
        elestr(1,1,gpn) = d1
        elestr(1,2,gpn) = d2
        elestr(1,3,gpn) = ds
        elestr(1,4,gpn) = dn
        avgs(1:4)       = avgs(1:4) + elestr(1,1:4,gpn)
        if( local_debug ) write(kout,9030) gpn, elestr(1,1:4,gpn)
c
      end do
c
      if( center_output ) then
        avgs(1:4)       = avgs(1:4) / dble( num_int_points )
        d1              = avgs(1)
        d2              = avgs(2)
        ds              = sqrt( d1**2 + d2**2 )
        dn              = avgs(4)
c
        elestr(1,1,1) = d1
        elestr(1,2,1) = d2
        elestr(1,3,1) = ds
        elestr(1,4,1) = dn
        if( local_debug ) write(kout,9032) elestr(1,1:4,1)
      end if
c
      return
c
 9020 format(/,"... other cohesive model: displ jumps ...",/,
     & 10x,'int pt',5x,'d1',9x,'d2',10x,'ds',10x,'dn' )
 9030 format(10x,i2,4f12.4)
 9032 format(9x,'avg',4f12.4)
c
       end subroutine ouhrks_simple_displ_jumps

c     ****************************************************************
c     *                                                              *
c     *             subroutine ouhrks_ppr_displ_jumps                *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 3/11/13 rhd                *
c     *                                                              *
c     *     pull together displacement jumps output values for       *
c     *     ppr cohesive                                             *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_ppr_displ_jumps
      implicit integer (a-z)
c
c             locals (see also contains main)
c
      double precision
     &   d1, d2, dn, ds, dn_limit, ds_limit,
     &   ratio_normal, ratio_shear, dn_at_peak, ds_at_peak
c
      if( local_debug ) write(kout,9020)
c
      ratio_normal       = props(37,elem)
      ratio_shear        = props(39,elem)
c
      do gpn = 1, num_int_points
c
        dn_limit   = elem_hist(1,1,gpn)
        ds_limit   = elem_hist(1,2,gpn)
        ds_at_peak = ds_limit * ratio_shear
        dn_at_peak = dn_limit * ratio_normal
c
        d1              = ddtse(1,1,gpn)
        d2              = ddtse(1,2,gpn)
        dn              = ddtse(1,3,gpn)
        ds              = sqrt( d1*d1 + d2*d2 )
c
        elestr(1,1,gpn) = d1
        elestr(1,2,gpn) = d2
        elestr(1,3,gpn) = ds
        elestr(1,4,gpn) = dn
        elestr(1,5,gpn) = ds / ds_at_peak
        elestr(1,6,gpn) = dn / dn_at_peak
        avgs(1:6)       = avgs(1:6) + elestr(1,1:6,gpn)
        avgs(7)         = avgs(7) + ds_at_peak
        avgs(8)         = avgs(8) + dn_at_peak
        if( local_debug ) write(kout,9030) gpn, elestr(1,1:6,gpn)
c
      end do
c
      if( center_output ) then
        avgs(1:8)       = avgs(1:8) / dble( num_int_points )
        d1              = avgs(1)
        d2              = avgs(2)
        ds              = sqrt( d1**2 + d2**2 )
        dn              = avgs(4)
        ds_at_peak      = avgs(7)
        dn_at_peak      = avgs(8)
c
        elestr(1,1,1) = d1
        elestr(1,2,1) = d2
        elestr(1,3,1) = ds
        elestr(1,4,1) = dn
        elestr(1,5,1) = ds / ds_at_peak
        elestr(1,6,1) = dn / dn_at_peak
        if( local_debug ) write(kout,9032) elestr(1,1:6,1)
      end if
c
      return
c
 9020 format(/,"... ppr model: displ jumps ...",/,
     & 10x,'int pt',5x,'d1',9x,'d2',10x,'ds',10x,'dn',
     &  9x,'ds/ds-peak',5x,'dn/dn-peak' )
 9030 format(10x,i2,6f12.4)
 9032 format(9x,'avg',6f12.4)
c
       end subroutine ouhrks_ppr_displ_jumps

c     ****************************************************************
c     *                                                              *
c     *             subroutine ouhrks_exp1_displ_jumps               *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 3/11/13 rhd                *
c     *                                                              *
c     *     pull together displacement jumps output values for       *
c     *     exponential cohesive                                     *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_exp1_displ_jumps
      implicit integer (a-z)
c
c             locals (see also contains main)
c
      double precision
     &   deff_peak, beta, d1, d2, dn, ds, deff,
     &   normalized_deff
c
      if( local_debug ) write(kout,9020)
c
      deff_peak          = props(22,elem)
      beta               = props(23,elem)
c
      do gpn = 1, num_int_points
        d1              = ddtse(1,1,gpn)
        d2              = ddtse(1,2,gpn)
        dn              = ddtse(1,3,gpn)
        ds              = sqrt( d1*d1 + d2*d2 )
        deff            = sqrt( beta*beta*ds*ds + dn*dn )
        normalized_deff = deff / deff_peak
        elestr(1,1,gpn) = d1
        elestr(1,2,gpn) = d2
        elestr(1,3,gpn) = ds
        elestr(1,4,gpn) = dn
        elestr(1,5,gpn) = deff
        elestr(1,6,gpn) = normalized_deff
        avgs(1:6)       = avgs(1:6) + elestr(1,1:6,gpn)
        if( local_debug ) write(kout,9030) gpn, elestr(1,1:6,gpn)
      end do
c
      if( center_output ) then
        avgs(1:6)       = avgs(1:6) / dble( num_int_points )
        d1              = avgs(1)
        d2              = avgs(2)
        ds              = sqrt( d1**2 + d2**2 )
        dn              = avgs(4)
        deff            = sqrt( beta*beta*ds*ds + dn*dn )
        normalized_deff = deff / deff_peak
c
        elestr(1,1,1) = d1
        elestr(1,2,1) = d2
        elestr(1,3,1) = ds
        elestr(1,4,1) = dn
        elestr(1,5,1) = deff
        elestr(1,6,1) = normalized_deff
        if( local_debug ) write(kout,9032) elestr(1,1:6,1)
      end if
c
      return
c
 9020 format(/,"... exponential model: displ jumps ...",/,
     & 10x,'int pt',5x,'d1',9x,'d2',10x,'ds',10x,'dn',
     &  9x,'deff',5x,'deff/dpeak' )
 9030 format(10x,i2,6f12.4)
 9032 format(9x,'avg',6f12.4)
c
       end subroutine ouhrks_exp1_displ_jumps

c     ****************************************************************
c     *                                                              *
c     *                subroutine ouhrks_exp1_tractions              *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 3/11/13 rhd                *
c     *                                                              *
c     *     pull together tractions output values for exponential    *
c     *     cohesive                                                 *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_exp1_tractions
      implicit integer (a-z)
c
c             locals (see also contains main)
c
      double precision
     &   t1, t2, tn, gamma, gamma_ur,
     &   teff, teff_peak, beta,ts, normalized_teff
c
      if( local_debug ) write(kout,9020)
c
      teff_peak = props(13,elem)
      beta      = props(23,elem)
c
      do gpn = 1, num_int_points
        t1       = urcs_blk_n(1,1,gpn)
        t2       = urcs_blk_n(1,2,gpn)
        tn       = urcs_blk_n(1,3,gpn)
        gamma    = urcs_blk_n(1,7,gpn)
        gamma_ur = urcs_blk_n(1,8,gpn)
        teff     = elem_hist(1,3,gpn)
        ts       = sqrt( t1*t1 + t2*t2 )
        normalized_teff = teff / teff_peak
        elestr(1,1,gpn) = t1
        elestr(1,2,gpn) = t2
        elestr(1,3,gpn) = ts
        elestr(1,4,gpn) = tn
        elestr(1,5,gpn) = teff
        elestr(1,6,gpn) = normalized_teff
        elestr(1,7,gpn) = gamma
        elestr(1,8,gpn) = gamma_ur
        avgs(1:8)     = avgs(1:8) + elestr(1,1:8,gpn)
        if( local_debug ) write(kout,9030) gpn, elestr(1,1:8,gpn)
      end do
c
      if( center_output ) then
        avgs(1:8)       = avgs(1:8) / dble( num_int_points )
        t1              = avgs(1)
        t2              = avgs(2)
        ts              = sqrt( t1**2 + t2**2 )
        tn              = avgs(4)
        teff            = sqrt( ts*ts/beta/beta + tn**2 )
        normalized_teff = teff / teff_peak
        gamma           = avgs(7)
        gamma_ur        = avgs(8)
c
        elestr(1,1,1) = t1
        elestr(1,2,1) = t2
        elestr(1,3,1) = ts
        elestr(1,4,1) = tn
        elestr(1,5,1) = teff
        elestr(1,6,1) = normalized_teff
        elestr(1,7,1) = gamma
        elestr(1,8,1) = gamma_ur
        if( local_debug ) write(kout,9032) elestr(1,1:8,1)
      end if
c
      return
c
 9020 format(/,"... exponential model: tractions ...",/,
     & 10x,'int pt',5x,'t1',9x,'t2',10x,'ts',10x,'tn',
     &  9x,'teff',5x,'teff/tmax',5x,'E(tot)',6x,'E(plas)' )
 9030 format(10x,i2,8f12.4)
 9032 format(9x,'avg',8f12.4)
c
       end subroutine ouhrks_exp1_tractions
c     ****************************************************************
c     *                                                              *
c     *                subroutine ouhrks_ppr_tractions               *
c     *                                                              *
c     *                       written by : rhd                       *
c     *                                                              *
c     *                   last modified : 3/11/13 rhd                *
c     *                                                              *
c     *     pull together traction output values for ppr cohesive    *
c     *     model                                                    *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine ouhrks_ppr_tractions
      implicit integer (a-z)
c
c             locals (see also contains main)
c
      double precision
     &   tn_peak, ts_peak, t1, t2, tn, gamma,
     &   gamma_ur, ts
c
      tn_peak = props(13,elem)
      ts_peak = props(14,elem)
c
      if( local_debug ) write(kout,9020)

c
      do gpn = 1, num_int_points
        t1       = urcs_blk_n(1,1,gpn)
        t2       = urcs_blk_n(1,2,gpn)
        tn       = urcs_blk_n(1,3,gpn)
        gamma    = urcs_blk_n(1,7,gpn)
        gamma_ur = urcs_blk_n(1,8,gpn)
        ts       = sqrt( t1*t1 + t2*t2 )
        elestr(1,1,gpn) = t1
        elestr(1,2,gpn) = t2
        elestr(1,3,gpn) = ts
        elestr(1,4,gpn) = tn
        elestr(1,5,gpn) = ts / ts_peak
        elestr(1,6,gpn) = tn / tn_peak
        elestr(1,7,gpn) = gamma
        elestr(1,8,gpn) = gamma_ur
        avgs(1:8)     = avgs(1:8) + elestr(1,1:8,gpn)
        if( local_debug ) write(kout,9030) gpn, elestr(1,1:8,gpn)
      end do
c
      if( center_output ) then
        avgs(1:8)       = avgs(1:8) / dble( num_int_points )
        t1              = avgs(1)
        t2              = avgs(2)
        ts              = sqrt( t1**2 + t2**2 )
        tn              = avgs(4)
        gamma           = avgs(7)
        gamma_ur        = avgs(8)
c
        elestr(1,1,1) = t1
        elestr(1,2,1) = t2
        elestr(1,3,1) = ts
        elestr(1,4,1) = tn
        elestr(1,5,1) = ts / ts_peak
        elestr(1,6,1) = tn / tn_peak
        elestr(1,7,1) = gamma
        elestr(1,8,1) = gamma_ur
        if( local_debug ) write(kout,9032) elestr(1,1:8,1)
      end if
c
      return
c
 9020 format(/,"... ppr model: tractions ...",/,
     & 10x,'int pt',5x,'t1',9x,'t2',10x,'ts',10x,'tn',
     &  5x,'ts/tpeak',6x,'tn/tpeak',5x,'E(tot)', 6x,'E(plas)' )
 9030 format(10x,i2,8f12.4)
 9032 format(9x,'avg',8f12.4)
c
      end subroutine ouhrks_ppr_tractions
c
      end subroutine ouhrks_cohesive


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2015 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine greens(inpc,textpart,nmethod,iperturb,
     &  isolver,istep,istat,n,iline,ipol,inl,ipoinp,inp,
     &  ithermal,ipoinpc)
!
!     reading the input deck: *GREEN
!
!     isolver=0: SPOOLES
!             7: pardiso
!
      implicit none
!
      character*1 inpc(*)
      character*20 solver
      character*132 textpart(16)
!
      integer nmethod,iperturb,isolver,istep,istat,n,key,i,
     &  iline,ipol,inl,ipoinp(2,*),inp(3,*),ithermal,ipoinpc(0:*)
!
      if((iperturb.eq.1).and.(istep.ge.1)) then
         write(*,*) '*ERROR reading *GREEN:'
         write(*,*) '       perturbation analysis is'
         write(*,*) '       not provided in a *GREEN'
         write(*,*) '       step.'
         call exit(201)
      endif
!
      if(istep.lt.1) then
         write(*,*) '*ERROR reading *GREEN:'
         write(*,*) '       *GREEN can only be used'
         write(*,*) '       within a STEP'
         call exit(201)
      endif
!
!     no heat transfer analysis
!
      if(ithermal.gt.1) then
         ithermal=1
      endif
!
!     default solver
!
      solver='                    '
      if(isolver.eq.0) then
         solver(1:7)='SPOOLES'
      elseif(isolver.eq.2) then
         solver(1:16)='ITERATIVESCALING'
      elseif(isolver.eq.3) then
         solver(1:17)='ITERATIVECHOLESKY'
      elseif(isolver.eq.4) then
         solver(1:3)='SGI'
      elseif(isolver.eq.5) then
         solver(1:5)='TAUCS'
      elseif(isolver.eq.7) then
         solver(1:7)='PARDISO'
      endif
!
      do i=2,n
         if(textpart(i)(1:7).eq.'SOLVER=') then
            read(textpart(i)(8:27),'(a20)') solver
         else
            write(*,*) '*WARNING reading *GREEN:'
            write(*,*) '         parameter not recognized:'
            write(*,*) '         ',
     &                 textpart(i)(1:index(textpart(i),' ')-1)
            call inputwarning(inpc,ipoinpc,iline,
     &"*GREEN%")
         endif
      enddo
!
      if(solver(1:7).eq.'SPOOLES') then
         isolver=0
      elseif(solver(1:7).eq.'PARDISO') then
         isolver=7
      else
         write(*,*) '*ERROR reading *GREEN:'
         write(*,*) '       solver:',solver,'is not allowed.'
         write(*,*) '       please specify SPOOLES or PARDISO'
         call exit(201)
      endif
!
      nmethod=11
!
      call getnewline(inpc,textpart,istat,n,key,iline,ipol,inl,
     &     ipoinp,inp,ipoinpc)
!
      return
      end


MODULE common_obs_oceanmodel
!=======================================================================
!
! [PURPOSE:] Observational procedures
!
! [HISTORY:]
!   01/23/2009 Takemasa MIYOSHI  created
!   04/26/2011 Steve PENNY converted to OCEAN for use with MOM4. grep '(OCEAN)' for changes.
!   01/18/2015 Steve Penny converted for use with MOM6
!   04/06/2015 Steve Penny converted for use with SIS
!   03/14/2017 Steve Penny converted for use with CICE
!
!=======================================================================
  USE common
  USE common_oceanmodel
  USE kdtree

  IMPLICIT NONE

  PUBLIC Trans_XtoY, phys2ijk, read_obs, get_nobs, read_obs2, write_obs2, itpl_2d, itpl_3d, monit_dep
  PUBLIC center_obs_coords

  PRIVATE
  TYPE(KD_ROOT), SAVE :: kdtree_root
  INTEGER, SAVE       :: initialized = 0
  REAL(r_size), SAVE  :: prev_lon, prev_lat      !STEVE: for checking if this longitude was last searched
  INTEGER             :: k_sought=1
  INTEGER             :: k_found

  INTEGER, SAVE, ALLOCATABLE      :: idx(:)      !STEVE: index of the observations that are found by kd_search_radius
  REAL(r_size), SAVE, ALLOCATABLE :: dist(:)     !STEVE: distance from the center grid point
  INTEGER, SAVE :: nn                            !STEVE: total number of local observations found by kd_search_radius

  ! For debugging kdtree:
  REAL(r_size), ALLOCATABLE, DIMENSION(:) :: lon2ij, lat2ij

CONTAINS
!-----------------------------------------------------------------------
! Transformation from model space to observation space (i.e. H-operator)
!-----------------------------------------------------------------------
SUBROUTINE Trans_XtoY(elm,ri,rj,rk,v3d,v2d,yobs)        !(OCEAN)
  USE params_model, ONLY: iv3d_hs, iv3d_hi, iv3d_t1, iv3d_ps, iv2d_cn, iv2d_ui, iv2d_vi
  USE params_model, ONLY: nlon,nlat,nlev,nv3d,nv2d
  USE params_obs,   ONLY: id_hs_obs, id_hi_obs, id_t1_obs, id_t2_obs, id_cn_obs, id_ui_obs, id_vi_obs
  IMPLICIT NONE
  REAL(r_size),INTENT(IN) :: elm
  REAL(r_size),INTENT(IN) :: ri,rj,rk
  REAL(r_size),INTENT(IN) :: v3d(nlon,nlat,nlev,nv3d)
  REAL(r_size),INTENT(IN) :: v2d(nlon,nlat,nv2d)
  REAL(r_size),INTENT(OUT) :: yobs
  INTEGER :: i,j,k
  INTEGER :: intelm

  intelm = NINT(elm)
  SELECT CASE (intelm)
  CASE(id_cn_obs)  ! concentration of sea-ice         !(SIS)
    !STEVE: need a conversion from modeled to observed field, unless the diagnostic field has it...
!   CALL itpl_3d(v3d(:,:,:,iv3d_hs),ri,rj,rk,yobs)    !(SIS)
    CALL itpl_2d(v2d(:,:,iv2d_cn),ri,rj,yobs)         !(SIS)
  CASE(id_ui_obs)  ! zonal drift of sea-ice           !(SIS)
    CALL itpl_2d(v2d(:,:,iv2d_ui),ri,rj,yobs)         !(SIS)
  CASE(id_vi_obs)  ! meridional drift of sea-ice      !(SIS)
    CALL itpl_2d(v2d(:,:,iv2d_vi),ri,rj,yobs)         !(SIS)
  CASE DEFAULT
    print *, "ERROR::Trans_XtoY:: observation type not recognized."
    print *, "element id = ", intelm
    print *, "available id's = ", id_hs_obs, id_hi_obs, id_t1_obs, id_t1_obs, id_cn_obs, id_ui_obs, id_vi_obs
    print *, "STEVE: STOPPING ON PURPOSE..."
    STOP 1
  END SELECT

END SUBROUTINE Trans_XtoY

!-----------------------------------------------------------------------
! Coordinate conversion
!-----------------------------------------------------------------------
SUBROUTINE phys2ijk(elem,rlon,rlat,rlev,ri,rj,rk)     !(OCEAN)
  USE vars_model,   ONLY: lon, lat, lev
  USE vars_model,   ONLY: lon0, lonf, lat0, latf
  USE vars_model,   ONLY: lon2d, lat2d !, lev2d
  USE params_model, ONLY: nlon, nlat, nlev
! USE params_model, ONLY: iv2d_eta, iv2d_sst, iv2d_sss, iv2d_ssh
  IMPLICIT NONE
  REAL(r_size),INTENT(IN) :: elem
  REAL(r_size),INTENT(IN) :: rlon
  REAL(r_size),INTENT(IN) :: rlat
  REAL(r_size),INTENT(IN) :: rlev ! pressure levels
  REAL(r_size),INTENT(OUT) :: ri
  REAL(r_size),INTENT(OUT) :: rj
  REAL(r_size),INTENT(OUT) :: rk
  REAL(r_size) :: aj,ak,ai, rrlon, glon,glat,xlon,xlat
  INTEGER :: i,j,k, n, ni,nj, ii,jj
  LOGICAL, PARAMETER :: dodebug = .false.

  !-----------------------------------------------------------------------------
  ! Initialize the KD-tree for the model-grid
  !-----------------------------------------------------------------------------
  !STEVE: NOTE: this is replicated for each process
  if (initialized == 0) then
    WRITE(6,*) "Initializing the obs_local()"
    initialized = 1
    call kd_init( kdtree_root, RESHAPE(lon2d(:,:),(/nlon*nlat/)), RESHAPE(lat2d(:,:),(/nlon*nlat/)) )
    WRITE(6,*) "Done constructing KD search tree."
    WRITE(6,*) "nlon*nlat = ", nlon*nlat
    ALLOCATE(dist(k_sought))
    ALLOCATE( idx(k_sought))
    prev_lon = -1e10
    prev_lat = -1e10

    ! To debug kdtree:
    if (dodebug) then
      ALLOCATE(lon2ij(nlon*nlat),lat2ij(nlon*nlat))
      lon2ij = RESHAPE(lon2d(:,:),(/nlon*nlat/))
      lat2ij = RESHAPE(lat2d(:,:),(/nlon*nlat/))
    endif
  endif

  !-----------------------------------------------------------------------------
  ! query the KD-tree
  !-----------------------------------------------------------------------------
  if (rlon .ne. prev_lon .or. rlat .ne. prev_lat) then
    CALL kd_search_nnearest(kdtree_root,  (/rlon, rlat/), k_sought, idx, dist, k_found, .false.)
    prev_lon = rlon
    prev_lat = rlat
    if (dodebug) then
      WRITE(6,*) "common_obs_mom6.f90::phys2ijk ---------------------------- "
      WRITE(6,*) "base observation point (lon/lat) :: ", rlon, rlat
      WRITE(6,*) "k_sought = ", k_sought
      WRITE(6,*) "k_found  = ", k_found
      WRITE(6,*) "Grid points found by kd_search_nnearest = "
      WRITE(6,*) "idx,ni,nj,lon,lat,dist"
      do n=1,k_found
        ni = MODULO(idx(n)-1,nlon)+1
        nj = idx(n)/nlon+1 ! Integer division
        WRITE(6,*) idx(n), ni,nj, lon2d(ni,nj), lat2d(ni,nj), dist(n)
      enddo
    endif
  endif

  !-----------------------------------------------------------------------------
  ! rlon -> ri, rlat -> rj
  !-----------------------------------------------------------------------------

  ! Find the appropriate grid box containing this observation

  ! First, find the index of the nearest grid point
  ni = MODULO(idx(1)-1,nlon)+1
  nj = FLOOR(REAL(idx(1))/REAL(nlon))+1 ! Integer division
  glon = lon2d(ni,nj)
  glat = lat2d(ni,nj)

  ! For debugging:
  if (dodebug) then
    xlon = lon2ij(idx(1))
    xlat = lat2ij(idx(1))
  endif

  !STEVE: initialize to something that will throw errors if it's not changed within
  ri = -1
  rj = -1
  rk = -1

  ! Second, check to see whether the observation is to the left/right, up/down from this point

  !-----------------------------------------------------------------------------
  ! Get longitude scaling
  !-----------------------------------------------------------------------------
  if (glon == rlon) then
    ai = 0.0
  elseif (glon < rlon) then
    ai = (rlon - lon2d(ni,nj)) / (lon2d(ni+1,nj) - lon2d(ni,nj))
  elseif (rlon < glon) then
    ai = (rlon - lon2d(ni,nj)) / (lon2d(ni,nj) - lon2d(ni-1,nj))
  endif
  ri = REAL(ni,r_size) + ai

  !-----------------------------------------------------------------------------
  ! Get latitude scaling
  !-----------------------------------------------------------------------------
  if (glat == rlat) then
    aj = 0.0
  elseif (glat < rlat) then
    aj = (rlat - lat2d(ni,nj)) / (lat2d(ni,nj+1) - lat2d(ni,nj))
  elseif (rlat < glat) then
    aj = (rlat - lat2d(ni,nj)) / (lat2d(ni,nj) - lat2d(ni,nj-1))
    !STEVE: should be negative
  endif
  rj = REAL(nj,r_size) + aj

  ! Set flags to mark rlon outside of map range:
  if (ri < 1) then
    ri = 0
  elseif(ri >= nlon+1) then
    ri = nlon+1
  endif

  if (rj < 1) then
    rj = 0
  elseif (rj >= nlat+1) then
    rj = nlat+1
  endif

  ! if (dodebug .and. (ri > nlon .or. ri < 1)) then
  if (dodebug) then
    WRITE(6,*) "================="
    WRITE(6,*) "In common_obs_mom6.f90::phys2ijk,"
    WRITE(6,*) "-----------------"
    WRITE(6,*) "rlon = ", rlon
    if (dodebug) WRITE(6,*) "xlon = ", xlon
    WRITE(6,*) "glon = ", glon
    WRITE(6,*) "ni = ", ni
    WRITE(6,*) "ai = ", ai
    WRITE(6,*) "ri = ", ri
    WRITE(6,*) "lon0 = ", lon0
    WRITE(6,*) "lonf = ", lonf
    WRITE(6,*) "-----------------"
    WRITE(6,*) "rlat = ", rlat
    if (dodebug) WRITE(6,*) "xlat = ", xlat
    WRITE(6,*) "glat = ", glat
    WRITE(6,*) "nj = ", nj
    WRITE(6,*) "aj = ", aj
    WRITE(6,*) "rj = ", rj
    WRITE(6,*) "lat0 = ", lat0
    WRITE(6,*) "latf = ", latf
    WRITE(6,*) "================="
  endif

  if (CEILING(ri) < 2 .OR. nlon+1 < CEILING(ri)) RETURN
  if (CEILING(rj) < 2 .OR. nlat < CEILING(rj)) RETURN

  ! No vertical dimension expected
  rk = 0.0

END SUBROUTINE phys2ijk

!-----------------------------------------------------------------------
! Interpolation
!-----------------------------------------------------------------------
PURE SUBROUTINE itpl_2d(var,ri,rj,var5)
  USE params_model, ONLY: nlon, nlat
  IMPLICIT NONE
  REAL(r_size),INTENT(IN) :: var(nlon,nlat)
  REAL(r_size),INTENT(IN) :: ri
  REAL(r_size),INTENT(IN) :: rj
  REAL(r_size),INTENT(OUT) :: var5
  REAL(r_size) :: ai,aj
  INTEGER :: i,j

  i = CEILING(ri)
  ai = ri - REAL(i-1,r_size)
  j = CEILING(rj)
  aj = rj - REAL(j-1,r_size)

  IF(i <= nlon) THEN
    var5 = var(i-1,j-1) * (1-ai) * (1-aj) &
       & + var(i  ,j-1) *    ai  * (1-aj) &
       & + var(i-1,j  ) * (1-ai) *    aj  &
       & + var(i  ,j  ) *    ai  *    aj

!   if (.true.) then
!     print *, "common_obs_sis.f90::itpl_2d::"
!     print *, "var(i-1,j-1) = ", var(i-1,j-1)
!     print *, "(1-ai) = ", (1-ai)
!     print *, "(1-aj) = ", (1-aj)
!     print *, "var(i  ,j-1) = ", var(i  ,j-1)
!     print *, "ai = ", ai
!     print *, "var(i-1,j  ) = ", var(i-1,j  )
!     print *, "aj = ", aj
!     print *, "var(i  ,j  ) = ", var(i  ,j  )
!     print *, "var5 = ", var5
!   endif

  ELSE
    var5 = var(i-1,j-1) * (1-ai) * (1-aj) &
       & + var(1  ,j-1) *    ai  * (1-aj) &
       & + var(i-1,j  ) * (1-ai) *    aj  &
       & + var(1  ,j  ) *    ai  *    aj
  END IF

END SUBROUTINE itpl_2d

PURE SUBROUTINE itpl_3d(var,ri,rj,rk,var5)
  USE params_model, ONLY: nlon,nlat,nlev
  IMPLICIT NONE
  REAL(r_size),INTENT(IN) :: var(nlon,nlat,nlev)
  REAL(r_size),INTENT(IN) :: ri
  REAL(r_size),INTENT(IN) :: rj
  REAL(r_size),INTENT(IN) :: rk
  REAL(r_size),INTENT(OUT) :: var5
  REAL(r_size) :: ai,aj,ak
  INTEGER :: i,j,k
  LOGICAL, PARAMETER :: dodebug = .false.

  i = CEILING(ri)
  ai = ri - REAL(i-1,r_size)
  j = CEILING(rj)
  aj = rj - REAL(j-1,r_size)
  k = CEILING(rk)
  ak = rk - REAL(k-1,r_size)

! if (dodebug) WRITE(6,*) "i,j,k,ai,aj,ak = ", i,j,k,ai,aj,ak

  IF(i <= nlon) THEN
    var5 = var(i-1,j-1,k-1) * (1-ai) * (1-aj) * (1-ak) &
       & + var(i  ,j-1,k-1) *    ai  * (1-aj) * (1-ak) &
       & + var(i-1,j  ,k-1) * (1-ai) *    aj  * (1-ak) &
       & + var(i  ,j  ,k-1) *    ai  *    aj  * (1-ak) &
       & + var(i-1,j-1,k  ) * (1-ai) * (1-aj) *    ak  &
       & + var(i  ,j-1,k  ) *    ai  * (1-aj) *    ak  &
       & + var(i-1,j  ,k  ) * (1-ai) *    aj  *    ak  &
       & + var(i  ,j  ,k  ) *    ai  *    aj  *    ak
  ELSE
    var5 = var(i-1,j-1,k-1) * (1-ai) * (1-aj) * (1-ak) &
       & + var(1  ,j-1,k-1) *    ai  * (1-aj) * (1-ak) &
       & + var(i-1,j  ,k-1) * (1-ai) *    aj  * (1-ak) &
       & + var(1  ,j  ,k-1) *    ai  *    aj  * (1-ak) &
       & + var(i-1,j-1,k  ) * (1-ai) * (1-aj) *    ak  &
       & + var(1  ,j-1,k  ) *    ai  * (1-aj) *    ak  &
       & + var(i-1,j  ,k  ) * (1-ai) *    aj  *    ak  &
       & + var(1  ,j  ,k  ) *    ai  *    aj  *    ak
  END IF

! if (dodebug) WRITE(6,*) "var5 = ", var5

END SUBROUTINE itpl_3d

!-----------------------------------------------------------------------
! Monitor departure
!-----------------------------------------------------------------------
SUBROUTINE monit_dep(nn,elm,dep,qc)
  USE params_obs,   ONLY: id_hs_obs, id_hi_obs, id_t1_obs, id_t2_obs, id_cn_obs, id_ui_obs, id_vi_obs
  IMPLICIT NONE
  INTEGER,INTENT(IN) :: nn
  REAL(r_size),INTENT(IN) :: elm(nn)
  REAL(r_size),INTENT(IN) :: dep(nn)
  INTEGER,INTENT(IN) :: qc(nn)
  REAL(r_size) :: rmse_hs,rmse_hi,rmse_t1,rmse_t2,rmse_cn,rmse_ui,rmse_vi
  REAL(r_size) :: bias_hs,bias_hi,bias_t1,bias_t2,bias_cn,bias_ui,bias_vi
  INTEGER :: n,ihs,ihi,it1,it2,icn,iui,ivi

  rmse_hs = 0.0d0
  rmse_hi = 0.0d0
  rmse_t1 = 0.0d0
  rmse_t2 = 0.0d0    !(OCEAN)
  rmse_cn = 0.0d0  !(OCEAN)
  rmse_ui = 0.0d0  !(OCEAN)
  rmse_vi = 0.0d0  !(OCEAN)
  bias_hs = 0.0d0
  bias_hi = 0.0d0
  bias_t1 = 0.0d0
  bias_t2 = 0.0d0    !(OCEAN)
  bias_cn = 0.0d0  !(OCEAN)
  bias_ui = 0.0d0  !(OCEAN)
  bias_vi = 0.0d0  !(OCEAN)
  ihs = 0
  ihi = 0
  it1 = 0
  it2 = 0            !(OCEAN)
  icn = 0          !(OCEAN)
  iui = 0          !(OCEAN)
  ivi = 0          !(OCEAN)
  DO n=1,nn
    IF(qc(n) /= 1) CYCLE
    SELECT CASE(NINT(elm(n)))
    CASE(id_hs_obs)
      rmse_hs = rmse_hs + dep(n)**2
      bias_hs = bias_hs + dep(n)
      ihs = ihs + 1
    CASE(id_hi_obs)
      rmse_hi = rmse_hi + dep(n)**2
      bias_hi = bias_hi + dep(n)
      ihi = ihi + 1
    CASE(id_t1_obs)
      rmse_t1 = rmse_t1 + dep(n)**2
      bias_t1 = bias_t1 + dep(n)
      it1 = it1 + 1
    CASE(id_t2_obs)                    !(OCEAN)
      rmse_t2 = rmse_t2 + dep(n)**2     !(OCEAN)
      bias_t2 = bias_t2 + dep(n)        !(OCEAN)
      it2 = it2 + 1                     !(OCEAN)
    CASE(id_cn_obs)                  !(OCEAN)
      rmse_cn = rmse_cn + dep(n)**2 !(OCEAN)
      bias_cn = bias_cn + dep(n)    !(OCEAN)
      icn = icn + 1                 !(OCEAN)
    CASE(id_ui_obs)                  !(OCEAN)
      rmse_ui = rmse_ui + dep(n)**2 !(OCEAN)
      bias_ui = bias_ui + dep(n)    !(OCEAN)
      iui = iui + 1                 !(OCEAN)
    CASE(id_vi_obs)                  !(OCEAN)
      rmse_vi = rmse_vi + dep(n)**2 !(OCEAN)
      bias_vi = bias_vi + dep(n)    !(OCEAN)
      ivi = ivi + 1                 !(OCEAN)
    END SELECT
  END DO
  IF(ihs == 0) THEN
    rmse_hs = undef
    bias_hs = undef
  ELSE
    rmse_hs = SQRT(rmse_hs / REAL(ihs,r_size))
    bias_hs = bias_hs / REAL(ihs,r_size)
  END IF
  IF(ihi == 0) THEN
    rmse_hi = undef
    bias_hi = undef
  ELSE
    rmse_hi = SQRT(rmse_hi / REAL(ihi,r_size))
    bias_hi = bias_hi / REAL(ihi,r_size)
  END IF
  IF(it1 == 0) THEN
    rmse_t1 = undef
    bias_t1 = undef
  ELSE
    rmse_t1 = SQRT(rmse_t1 / REAL(it1,r_size))
    bias_t1 = bias_t1 / REAL(it1,r_size)
  END IF
  IF(it2 == 0) THEN                                   !(OCEAN)
    rmse_t2 = undef                                   !(OCEAN)
    bias_t2 = undef                                   !(OCEAN)
  ELSE
    rmse_t2 = SQRT(rmse_t2 / REAL(it2,r_size))          !(OCEAN)
    bias_t2 = bias_t2 / REAL(it2,r_size)                !(OCEAN)
  END IF
  IF(icn == 0) THEN                                 !(OCEAN)
    rmse_cn = undef                                 !(OCEAN)
    bias_cn = undef                                 !(OCEAN)
  ELSE
    rmse_cn = SQRT(rmse_cn / REAL(icn,r_size))    !(OCEAN)
    bias_cn = bias_cn / REAL(icn,r_size)          !(OCEAN)
  END IF
  IF(iui == 0) THEN                                 !(OCEAN)
    rmse_ui = undef                                 !(OCEAN)
    bias_ui = undef                                 !(OCEAN)
  ELSE
    rmse_ui = SQRT(rmse_ui / REAL(iui,r_size))    !(OCEAN)
    bias_ui = bias_ui / REAL(iui,r_size)          !(OCEAN)
  END IF
  IF(ivi == 0) THEN                                 !(OCEAN)
    rmse_vi = undef                                 !(OCEAN)
    bias_vi = undef                                 !(OCEAN)
  ELSE
    rmse_vi = SQRT(rmse_vi / REAL(ivi,r_size))    !(OCEAN)
    bias_vi = bias_vi / REAL(ivi,r_size)          !(OCEAN)
  END IF

  WRITE(6,'(A)') '== OBSERVATIONAL DEPARTURE ============================================='
  WRITE(6,'(7A12)') 'HS','HI','T1','T2','CN','UI','VI'
  WRITE(6,'(7ES12.3)') bias_hs,bias_hi,bias_t1,bias_t2,bias_cn,bias_ui,bias_vi
  WRITE(6,'(7ES12.3)') rmse_hs,rmse_hi,rmse_t1,rmse_t2,rmse_cn,bias_ui,rmse_vi
  WRITE(6,'(A)') '== NUMBER OF OBSERVATIONS TO BE ASSIMILATED ============================'
  WRITE(6,'(7A12)') 'HS','HI','T1','T2','CN','UI','VI'
  WRITE(6,'(7I12)') ihs,ihi,it1,it2,icn,iui,ivi
  WRITE(6,'(A)') '========================================================================'

END SUBROUTINE monit_dep
!-----------------------------------------------------------------------
! Basic modules for observation input
!-----------------------------------------------------------------------
SUBROUTINE get_nobs(cfile,nrec,nn)
  USE params_obs,   ONLY: id_hs_obs, id_hi_obs, id_t1_obs, id_t2_obs, id_cn_obs, id_ui_obs, id_vi_obs
  IMPLICIT NONE
  CHARACTER(*),INTENT(IN) :: cfile
  INTEGER,INTENT(IN) :: nrec
  INTEGER,INTENT(OUT) :: nn
  REAL(r_sngl),ALLOCATABLE :: wk(:)
  INTEGER :: ios
  INTEGER :: ihs,ihi,it1,it2,icn,iui,ivi
  INTEGER :: iunit
  LOGICAL :: ex
  LOGICAL, PARAMETER :: dodebug=.false.
  INTEGER :: cnt_ice, cnt_water, cnt_mix

  ALLOCATE(wk(nrec))
  nn = 0
  ihs = 0
  ihi = 0
  it1 = 0
  it2 = 0       !(OCEAN)
  icn = 0       !(OCEAN)
  iui = 0       !(OCEAN)
  ivi = 0       !(OCEAN)
  cnt_ice = 0
  cnt_water = 0
  cnt_mix = 0
  iunit=91
  if (dodebug) print *, "get_nobs::"
  INQUIRE(FILE=cfile,EXIST=ex)
  IF(ex) THEN
    OPEN(iunit,FILE=cfile,FORM='unformatted',ACCESS='sequential')
    DO
      READ(iunit,IOSTAT=ios) wk
      if (dodebug .and. nrec.eq.6) then
        PRINT '(I6,2F7.2,F10.2,2F12.2)',NINT(wk(1)),wk(2),wk(3),wk(4),wk(5),wk(6)
      elseif (dodebug .and. nrec .eq. 8) then
        PRINT '(I6,2F7.2,F10.2,4F12.2)',NINT(wk(1)),wk(2),wk(3),wk(4),wk(5),wk(6),wk(7),wk(8)
      elseif (dodebug .and. nrec .eq. 9) then
        PRINT '(I6,2F7.2,F10.2,5F12.2)',NINT(wk(1)),wk(2),wk(3),wk(4),wk(5),wk(6),wk(7),wk(8),wk(9)
      endif
      IF(ios /= 0) EXIT
      SELECT CASE(NINT(wk(1)))
      CASE(id_hs_obs)
        ihs = ihs + 1
      CASE(id_hi_obs)
        ihi = ihi + 1
      CASE(id_t1_obs)
        it1 = it1 + 1
      CASE(id_t2_obs)     !(OCEAN)
        it2 = it2 + 1      !(OCEAN)
      CASE(id_cn_obs)   !(OCEAN)
        icn = icn + 1  !(OCEAN)
        if (wk(5) > 0) then
          if (wk(5) < 1) then
            cnt_mix = cnt_mix + 1
          else
            cnt_ice = cnt_ice + 1
          endif
        else
          cnt_water = cnt_water + 1
        endif
      CASE(id_ui_obs)   !(OCEAN)
        iui = iui + 1  !(OCEAN)
      CASE(id_vi_obs)   !(OCEAN)
        ivi = ivi + 1  !(OCEAN)
      END SELECT
      nn = nn + 1
    END DO
    WRITE(6,'(I10,A)') nn,' TOTAL OBSERVATIONS INPUT (in get_nobs)'
    WRITE(6,'(A12,I10)') '         HS:',ihs
    WRITE(6,'(A12,I10)') '         HI:',ihi
    WRITE(6,'(A12,I10)') '         T1:',it1
    WRITE(6,'(A12,I10)') '         T2:',it2   !(OCEAN)
    WRITE(6,'(A12,I10)') '         CN:',icn !(OCEAN)
    WRITE(6,'(A12,I10)') '         UI:',iui !(OCEAN)
    WRITE(6,'(A12,I10)') '         VI:',ivi !(OCEAN)
    WRITE(6,'(A27)') 'Concentration Distribution:'
    WRITE(6,'(A13,I10,A11,F5.2,A1)') ' water/land: ',cnt_water, ' cells, or ', 100*REAL(cnt_water)/REAL(icn),'%'
    WRITE(6,'(A13,I10,A11,F5.2,A1)') '  mixed ice: ',cnt_mix,   ' cells, or ', 100*REAL(cnt_mix)/REAL(icn),'%'
    WRITE(6,'(A13,I10,A11,F5.2,A1)') '  solid ice: ',cnt_ice,   ' cells, or ', 100*REAL(cnt_ice)/REAL(icn),'%'
    CLOSE(iunit)
  ELSE
    WRITE(6,'(2A)') cfile,' does not exist -- skipped'
  END IF
  DEALLOCATE(wk)

  if (nn .eq. 0) then
    WRITE(6,*) "get_nobs:: WARNING: No observations have been found! Ensure that at least one timeslot has observations."
!   STOP(60)
  endif

END SUBROUTINE get_nobs

SUBROUTINE read_obs(cfile,nn,elem,rlon,rlat,rlev,odat,oerr,obhr)
  USE params_model, ONLY: nlon
  USE vars_model, ONLY: lon0, lonf
  USE vars_model, ONLY: lon,lat
  IMPLICIT NONE
  CHARACTER(*),INTENT(IN) :: cfile
  INTEGER,INTENT(IN) :: nn
  REAL(r_size),INTENT(OUT) :: elem(nn) ! element number
  REAL(r_size),INTENT(OUT) :: rlon(nn)
  REAL(r_size),INTENT(OUT) :: rlat(nn)
  REAL(r_size),INTENT(OUT) :: rlev(nn)
  REAL(r_size),INTENT(OUT) :: odat(nn)
  REAL(r_size),INTENT(OUT) :: oerr(nn)
  REAL(r_size),INTENT(OUT) :: obhr(nn)
! REAL(r_sngl) :: wk(6)
  REAL(r_sngl) :: wk(9)
  !REAL(r_size) :: wk(6) !(OCEAN) STEVE: I changed this because the netcdf observation files are stored as double precision
  INTEGER :: n,iunit
  ! STEVE: for general grid
  LOGICAL, PARAMETER :: dodebug = .false.
  LOGICAL :: process_obs = .true.

  iunit=91
  OPEN(iunit,FILE=cfile,FORM='unformatted',ACCESS='sequential')
  DO n=1,nn
    READ(iunit) wk
    elem(n) = REAL(wk(1),r_size)
    rlon(n) = REAL(wk(2),r_size)
    rlat(n) = REAL(wk(3),r_size)
    rlev(n) = REAL(wk(4),r_size)
    odat(n) = REAL(wk(5),r_size)
    oerr(n) = REAL(wk(6),r_size)
    obhr(n) = REAL(wk(7),r_size)

    !STEVE: error check
    if (oerr(n) .le. 0) then
      print *, "common_obs_sis.f90::read_obs:: WARNING!"
      print *, "STEVE: oerr <= 0, must be > 0 ..."
      print *, "STEVE: oerr(",n,") = ", oerr(n)
      PRINT '(I6,2F7.2,F10.2,2F12.2)',NINT(wk(1)),wk(2),wk(3),wk(4),wk(5),wk(6),wk(7),wk(8),wk(9)
!     stop 9
    endif

    ! Special processing for obs:
    !STEVE: this handles the fact that the observations are typically on a 0 to 360º grid, while
    !       the NCEP mom4p1 grid configuration is on a ~ -285 to 75º grid
    if (process_obs) then
      CALL center_obs_coords(rlon,oerr,nn)
    endif

  END DO
  CLOSE(iunit)

  if (MAXVAL(rlon) > lonf) then
    WRITE(6,*) "read_obs:: Error: MAX(observation lon, i.e. rlon) > lonf"
    WRITE(6,*) "rlon = ", rlon
    WRITE(6,*) "lonf = ", lonf
    WRITE(6,*) "lon(nlon) = ", lon(nlon)
    STOP(2)
  endif
  if (MINVAL(rlon) < lon0) then
    WRITE(6,*) "read_obs:: Error: MIN(observation lon, i.e. rlon) < lon0"
    WRITE(6,*) "rlon = ", rlon
    WRITE(6,*) "lon0 = ", lon0
    WRITE(6,*) "lon(1) = ", lon(1)
    STOP(2)
  endif

END SUBROUTINE read_obs

SUBROUTINE read_obs2(cfile,nn,elem,rlon,rlat,rlev,odat,oerr,ohx,oqc,obhr)
  USE params_model, ONLY: obs_noise_coeff
  IMPLICIT NONE
  CHARACTER(*),INTENT(IN) :: cfile
  INTEGER,INTENT(IN) :: nn
  REAL(r_size),INTENT(OUT) :: elem(nn) ! element number
  REAL(r_size),INTENT(OUT) :: rlon(nn)
  REAL(r_size),INTENT(OUT) :: rlat(nn)
  REAL(r_size),INTENT(OUT) :: rlev(nn)
  REAL(r_size),INTENT(OUT) :: odat(nn)
  REAL(r_size),INTENT(OUT) :: oerr(nn)
  REAL(r_size),INTENT(OUT) :: ohx(nn)
  REAL(r_size),INTENT(OUT) :: obhr(nn)
  INTEGER,INTENT(OUT) :: oqc(nn)
  REAL(r_size) :: rand(nn)   !(SIS)
  REAL(r_sngl) :: wk(9)
  INTEGER :: n,iunit

  !STEVE: trying to handle numerical issues with ice concentration data type: (SIS)
  CALL com_randn(nn,rand) !(SIS)

  iunit=91
  OPEN(iunit,FILE=cfile,FORM='unformatted',ACCESS='sequential')
  DO n=1,nn
    READ(iunit) wk
!   SELECT CASE(NINT(wk(1)))
!   CASE(id_u_obs)
!     wk(4) = wk(4) * 100.0 ! hPa -> Pa
!   CASE(id_v_obs)
!     wk(4) = wk(4) * 100.0 ! hPa -> Pa
!   CASE(id_t_obs)
!     wk(4) = wk(4) * 100.0 ! hPa -> Pa
!   CASE(id_q_obs)
!     wk(4) = wk(4) * 100.0 ! hPa -> Pa
!  END SELECT
    elem(n) = REAL(wk(1),r_size)
    rlon(n) = REAL(wk(2),r_size)
    rlat(n) = REAL(wk(3),r_size)
    rlev(n) = REAL(wk(4),r_size)
    odat(n) = REAL(wk(5),r_size)
    oerr(n) = REAL(wk(6),r_size)
    ohx(n)  = REAL(wk(7),r_size)
    oqc(n)  = NINT(wk(8))
    obhr(n) = REAL(wk(9),r_size)

    !STEVE: add some 'inflation' (noise) to the ohx so the ensemble spread is not 0, (SIS)
    !       which is particularly important in high ice or open water areas...
    if ( odat(n) >= 0.99 .or. odat(n) <= 0.01 ) then
      ohx(n) = ohx(n) + rand(n) * (obs_noise_coeff * oerr(n)) !STEVE: scale the added noise to a percentage of the obs error
    endif
  END DO
  CLOSE(iunit)

END SUBROUTINE read_obs2

!STEVE: adding for support
SUBROUTINE write_obs(cfile,nn,elem,rlon,rlat,rlev,odat,oerr,obhr)
  IMPLICIT NONE
  CHARACTER(*),INTENT(IN) :: cfile
  INTEGER,INTENT(IN) :: nn
  REAL(r_size),INTENT(IN) :: elem(nn) ! element number
  REAL(r_size),INTENT(IN) :: rlon(nn)
  REAL(r_size),INTENT(IN) :: rlat(nn)
  REAL(r_size),INTENT(IN) :: rlev(nn)
  REAL(r_size),INTENT(IN) :: odat(nn)
  REAL(r_size),INTENT(IN) :: oerr(nn)
  REAL(r_size),INTENT(IN) :: obhr(nn)
  REAL(r_sngl) :: wk(9)
! REAL(r_size) :: wk(6) !(OCEAN) STEVE: I changed this because the netcdf observation files are stored as double precision
  INTEGER :: n,iunit

  iunit=91
  OPEN(iunit,FILE=cfile,FORM='unformatted',ACCESS='sequential')
  DO n=1,nn
    wk(1) = REAL(elem(n),r_sngl)
    wk(2) = REAL(rlon(n),r_sngl)
    wk(3) = REAL(rlat(n),r_sngl)
    wk(4) = REAL(rlev(n),r_sngl)
    wk(5) = REAL(odat(n),r_sngl)
    wk(6) = REAL(oerr(n),r_sngl)
    wk(7) = REAL(obhr(n),r_sngl)
    wk(8) = -1
    wk(9) = -1
    WRITE(iunit) wk
  END DO
  CLOSE(iunit)

END SUBROUTINE write_obs

SUBROUTINE write_obs2(cfile,nn,elem,rlon,rlat,rlev,odat,oerr,ohx,oqc,obhr)
  IMPLICIT NONE
  CHARACTER(*),INTENT(IN) :: cfile
  INTEGER,INTENT(IN) :: nn
  REAL(r_size),INTENT(IN) :: elem(nn) ! element number
  REAL(r_size),INTENT(IN) :: rlon(nn)
  REAL(r_size),INTENT(IN) :: rlat(nn)
  REAL(r_size),INTENT(IN) :: rlev(nn)
  REAL(r_size),INTENT(IN) :: odat(nn)
  REAL(r_size),INTENT(IN) :: oerr(nn)
  REAL(r_size),INTENT(IN) :: ohx(nn)
  REAL(r_size),INTENT(IN) :: obhr(nn)
  INTEGER,INTENT(IN) :: oqc(nn)
  REAL(r_sngl) :: wk(9)
  INTEGER :: n,iunit
  LOGICAL, PARAMETER :: dodebug=.false.

  iunit=92
  OPEN(iunit,FILE=cfile,FORM='unformatted',ACCESS='sequential')
  DO n=1,nn
    wk(1) = REAL(elem(n),r_sngl)  ! ID for observation type
    wk(2) = REAL(rlon(n),r_sngl)  ! Ob lon
    wk(3) = REAL(rlat(n),r_sngl)  ! Ob lat
    wk(4) = REAL(rlev(n),r_sngl)  ! Ob level
    wk(5) = REAL(odat(n),r_sngl)  ! Observed data quantity
    wk(6) = REAL(oerr(n),r_sngl)  ! Estimated observation error
    wk(7) = REAL(ohx(n),r_sngl)   ! Model forecast transformed to observation space: H(xb)
    wk(8) = REAL(oqc(n),r_sngl)   ! Quality control ID (1==keep, 0==discard) for use in assimilation
    wk(9) = REAL(obhr(n),r_sngl)   ! Quality control ID (1==keep, 0==discard) for use in assimilation
    if (dodebug) PRINT '(I6,2F7.2,F10.2,6F12.2)',NINT(wk(1)),wk(2),wk(3),wk(4),wk(5),wk(6),wk(7),wk(8),wk(9)
    WRITE(iunit) wk
  END DO
  CLOSE(iunit)

END SUBROUTINE write_obs2

SUBROUTINE center_obs_coords(rlon,oerr,nn)
!===============================================================================
! Center all observations within the longitudes defined by the model grid
!===============================================================================
  USE vars_model,   ONLY: lon0, lonf, wrapgap
  IMPLICIT NONE
  REAL(r_size),INTENT(INOUT) :: rlon(nn)
  REAL(r_size),INTENT(INOUT) :: oerr(nn)
  INTEGER, INTENT(IN) :: nn
  INTEGER :: n
  LOGICAL :: dodebug = .false.
  LOGICAL :: dodebug1 = .false.

  if (dodebug) then
    WRITE(6,*) "center_obs_coords::"
    WRITE(6,*) "wrapgap = ", wrapgap
  endif

  do n=1,nn

    if (rlon(n) >= lonf) then
      if (dodebug1) WRITE(6,*) "(a)"

      if (dodebug) then
        WRITE(6,*) "letkf_obs.f90:: Wrapping large lon obs to model grid: n = ", n
        WRITE(6,*) "pre : rlon(n) = ", rlon(n)
        WRITE(6,*) "360 - rlon(n) = ", 360.0 - rlon(n)
        WRITE(6,*) "abs(rlon(n) - lonf) = ", abs(rlon(n) - lonf)
      endif

      ! Update the coordinate
      if ( abs(rlon(n) - lonf) < wrapgap ) then
        if (dodebug1) WRITE(6,*) "(b)"
          ! First, handle observations that are just outside of the model grid
          !STEVE: shift it if it's just outside grid

        if (abs(rlon(n) - lonf) < wrapgap/2) then
            rlon(n) = lonf
        else
            rlon(n) = lon0
        endif

        ! Increase error to compensate
        oerr(n) = oerr(n)*2
      else
        if (dodebug1) WRITE(6,*) "(c)"
        ! Otherwise, wrap the observation coordinate to be inside of the defined model grid coordinates
        !Wrap the coordinate
        if (dodebug) then
          WRITE(6,*) "lon0    = ", lon0
          WRITE(6,*) "lonf    = ", lonf
          WRITE(6,*) "rlon(n) = ", rlon(n)
          WRITE(6,*) "wrapgap = ", wrapgap
        endif
        rlon(n) = REAL(lon0 + abs(rlon(n) - lonf) - wrapgap,r_size)
        if (dodebug) then
          WRITE(6,*) "After update:"
          WRITE(6,*) "rlon(n) = REAL(lon0 + abs(rlon(n) - lonf) - wrapgap,r_size)"
          WRITE(6,*) "rlon(n) = ", rlon(n)
        endif
      endif

      if (dodebug) WRITE(6,*) "post : rlon(n) = ", rlon(n)

    elseif (rlon(n) < lon0) then
      if (dodebug1) WRITE(6,*) "(d)"

      if (dodebug) then
          WRITE(6,*) "letkf_obs.f90:: Wrapping small lon obs to model grid: n = ", n
          WRITE(6,*) "pre  : rlon(n) = ", rlon(n)
          WRITE(6,*) "360 - rlon(n) = ", 360.0 - rlon(n)
      endif

      ! Update the coordinate
      if (abs(lon0 - rlon(n)) < wrapgap ) then
        if (dodebug1) WRITE(6,*) "(e)"
        !STEVE: shift it if it's just outside grid
        if (abs(lon0 - rlon(n)) < wrapgap/2) then
            rlon(n) = lon0
        else
            rlon(n) = lonf
        endif
        ! Increase error to compensate
        oerr(n) = oerr(n)*2
      else
        if (dodebug1) WRITE(6,*) "(f)"
        !Wrap the coordinate
        rlon(n) = REAL(lonf - abs(lon0 - rlon(n)) + wrapgap,r_size)
      endif

      if (dodebug) WRITE(6,*) "post : rlon(n) = ", rlon(n)

    endif
  enddo

  WRITE(6,*) "center_obs_coords:: finished recentering observations."
  if (MAXVAL(rlon) > lonf) then
    WRITE(6,*) "read_obs:: Error: MAX(observation lon, i.e. rlon) > lonf"
    WRITE(6,*) "MAXVAL(rlon) = ", MAXVAL(rlon)
    WRITE(6,*) "lonf = ", lonf
!   WRITE(6,*) "lon(nlon) = ", lon(nlon)
    STOP(22)
  endif
  if (MINVAL(rlon) < lon0) then
    WRITE(6,*) "read_obs:: Error: MIN(observation lon, i.e. rlon) < lon0"
    WRITE(6,*) "MINVAL(rlon) = ", MINVAL(rlon)
    WRITE(6,*) "lon0 = ", lon0
!   WRITE(6,*) "lon(1) = ", lon(1)
    STOP(23)
  endif

END SUBROUTINE center_obs_coords

END MODULE common_obs_oceanmodel


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   EVB-QMDFF - RPMD molecular dynamics and rate constant calculations on
!               black-box generated potential energy surfaces
!
!   Copyright (c) 2021 by Julien Steffen (steffen@pctc.uni-kiel.de)
!                         Stefan Grimme (grimme@thch.uni-bonn.de) (QMDFF code)
!
!   Permission is hereby granted, free of charge, to any person obtaining a
!   copy of this software and associated documentation files (the "Software"),
!   to deal in the Software without restriction, including without limitation
!   the rights to use, copy, modify, merge, publish, distribute, sublicense,
!   and/or sell copies of the Software, and to permit persons to whom the
!   Software is furnished to do so, subject to the following conditions:
!
!   The above copyright notice and this permission notice shall be included in
!   all copies or substantial portions of the Software.
!
!   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
!   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
!   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
!   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
!   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
!   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
!   DEALINGS IN THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

!
!     subroutine ffhess: calculate the numerical QMDFF hessian based
!               on the analytical gradients for parameter optimization
!
!     part of QMDFF
!
subroutine ffhess(n,at,xyz,q,r0ab,zab,r094,sr42,c6xy, &
    &    n3,iadr,hessatoms,ffh,ip)
implicit none
integer::n,n3,ip,at(n),iadr(2,n3)
integer::hessatoms(5,*)
integer::i,j,ii,jj,kk,ia,jc,ja,ic,ih
real(kind=8)::xyz(3,n),ffh(n3)
real(kind=8)::step,step2,gl(3,n),gr(3,n),e
real(kind=8)::r0ab(94,94),zab(94,94),r094(94,94)
real(kind=8)::sr42(94,94),c6xy(n,n),q(n)
real(kind=4),allocatable :: h(:,:)

allocate(h(3*n,3*n))

h=0

step=0.001
step2=1./(2.*step)
!
!     for the standard case: hessian of QMDFF minimum
!
if (ip.eq.0) then
   do ia = 1, n
      do ic = 1, 3
         ii = (ia-1)*3 + ic

         xyz(ic,ia)=xyz(ic,ia)+step
         call ff_eg (n,at,xyz,e,gr)
         call ff_nonb(n,at,xyz,q,r0ab,zab,r094, &
           &  sr42,c6xy,e,gr)
         call ff_hb(n,at,xyz,e,gr)

         xyz(ic,ia)=xyz(ic,ia)-2.*step

         call ff_eg (n,at,xyz,e,gl)
         call ff_nonb(n,at,xyz,q,r0ab,zab,r094, &
           &  sr42,c6xy,e,gl)
         call ff_hb(n,at,xyz,e,gl)
         xyz(ic,ia)=xyz(ic,ia)+step

         do ja = 1, n
            do jc = 1, 3
               jj = (ja-1)*3 + jc
               h(ii,jj) =(gr(jc,ja) - gl(jc,ja)) * step2
            end do
         end do
      end do
   end do
else
!
!     for Levenberg-Marquard derivations after force constants
!     to fill the matrix aa (called by pderiv-routine)
!
   do ih=1,hessatoms(5,ip)
      ia=hessatoms(ih,ip)
      do ic = 1, 3
         ii = (ia-1)*3 + ic

         xyz(ic,ia)=xyz(ic,ia)+step

         call ff_egh(n,at,xyz,e,gr,ia)

         xyz(ic,ia)=xyz(ic,ia)-2.*step

         call ff_egh(n,at,xyz,e,gl,ia)
         xyz(ic,ia)=xyz(ic,ia)+step

         do ja = 1, n
            do jc = 1, 3
               jj = (ja-1)*3 + jc
               h(ii,jj) =(gr(jc,ja) - gl(jc,ja)) * step2
            end do
         end do
      end do
   end do
end if
do kk=1,n3
   i=iadr(1,kk)
   j=iadr(2,kk)
   ffh(kk)=(h(i,j)+h(j,i))*0.5
end do

deallocate(h)

return
end subroutine ffhess