c     ****************************************************************
c     *                                                              *
c     *                      subroutine elem_load                    *
c     *                                                              *
c     *                       written by : ag                        *
c     *                                                              *
c     *                   last modified : 12/01/11 jcs               *
c     *                                                              *
c     *     this subroutine sets up the equivalent nodal loads       *
c     *     calcs for all element loads on a 3-d isoparametrics      *
c     *                                                              *
c     ****************************************************************
c
c           Here is how the face/body/pressure/temperature loading
c           storage strategy works:
c
c                 There is one 3 by 'eload_size' integer array and one
c                 'eload_size' long real array that store the loading
c                 information:
c
c                   eload_data(i,1) -- the element with the loading
c                                       description for entry i
c                   eload_data(i,2) -- the type of the loading for entry i:
c                               1 to  6 : face number for traction loading
c                                  0    : body force loading
c                              -1 to -6 : pressure loading
c                              -7 to -12: -face # for piston loading -6
c                                -100   : element temperature
c                   eload_data(i,3)  -- the dof for the loading for entry i
c                               (zero for pressure loading and
c                                temperature)
c                   eload_val(i)     -- the value of the force for entry i
c                                       value of element temperature
c                   eload_pist(i)   -- piston table number for entry i
c                   thread_number(i) -- thread number for entry i
c
c
      subroutine elem_load( eload_data, eload_val, size, eload_pist,
     &                      thread_number, mult_fact, eqloads )
      use global_data ! old common.main
c
      use main_data
c
      implicit integer (a-z)
c
c                global variables
c
      dimension eload_data(size,3), thread_number(size),
     &          eload_pist(size)
      real eload_val(size)
      double precision
     &     mult_fact, eqloads(*)
c
c                local variables
c
      logical debug
      double precision
     &      zero, nrmeq
c
      double precision,
     & dimension(:,:), allocatable :: del_eqload
c
      data debug, zero / .false., 0.0 /
c
      if ( debug ) then
         write (*,*) '>>>> entering elem_load.'
         call dump_load( eload_data, eload_val, thread_number, size )
      end if
c
c            allocate thread local arrays for eqload calculations.
c            we're handling the reduction process aross
c            threads by allocating a (private) work vector
c            for each thread.
c
      allocate( del_eqload(nodof,num_threads) )
      del_eqload(:,:) = zero
c
c            parallel section. each processor runs down the entire do
c            loop, but only performs work on the elements assigned
c            to it. otherwise the loop cycles.
c            each change in the eqload vector is marked by processor.
c
c$OMP PARALLEL PRIVATE(erow,now_thread,element,exe_thread)
      now_thread = omp_get_thread_num()+1
      do erow = 1,size
         exe_thread = thread_number(erow)
         if ( now_thread .ne. exe_thread ) cycle
         element    = eload_data(erow,1)
         if (debug) write(*,*) 'erow,elem,myid,exid',
     &        erow,element,now_thread,exe_thread
         call do_elem_load( element, eload_data(erow,2),
     &        eload_data(erow,3), eload_val(erow),
     &        eload_pist(erow), del_eqload(1,now_thread), mult_fact )
      end do
c$OMP END PARALLEL
c
c            reduce individual components of the array eqloads
c
      do j = 1, num_threads
         do i = 1, nodof
            eqloads(i) = eqloads(i) + del_eqload(i,j)
         end do
      end do
c
      deallocate( del_eqload )
c
      if ( debug ) then
         nrmeq = zero
         do i = 1,nodof
            nrmeq = nrmeq + eqloads(i)*eqloads(i)
         end do
         nrmeq = sqrt(nrmeq)
         write(*,*) 'Norm of equivalent loading vector: ',nrmeq
      end if

c
 9999 continue
      if (debug) write (*,*) '<<<< leaving elem_load.'
      return
      end
c  ****************************************************************
c  *                                                              *
c  *                  subroutine: do_elem_load                    *
c  *                                                              *
c  *                       written by : jcs                       *
c  *                                                              *
c  *                   last modified : 11/15/11 jcs               *
c  *                                                              *
c  *     this subroutine calculates the equivalent nodal loads    *
c  *     for all element loads on a 3-d isoparametrics            *
c  *                                                              *
c  ****************************************************************
c
c
      subroutine do_elem_load( element, eload_type, eload_dof,
     &     elval, eload_pist, del_eqload, mult_fact )
      use global_data ! old common.main
c
      use main_data
c
      implicit integer (a-z)
c
c     parameter declarations
c     ----------------------
c
      integer element, eload_type, eload_dof, eload_pist
      real elval
      double precision
     &     del_eqload(*), mult_fact
c
c     declare local variables
c     -----------------------
c
      double precision
     &      ecoord(3,mxndel), zero, body_intens, face_intens,
     &      equiv_loads_ele(mxndel), equiv_loads_face(mxndel,3),
     &      face_intensities(mxndel,3), dummy,
     &      p3, u3, m3, gam, fdirc(3)
c
      double precision,
     & dimension(:,:), pointer :: eforces
c
      dimension elem_nodes(mxndel), edest(mxedof)
      logical debug, geonl, body_flg, face_flg, nrml_flg, tet_elem,
     &        failed
      data debug, zero / .false., 0.0 /
c
c
      if (debug) write(*,*) '>> In do_elem_load'
c
      if (debug) then
         write(*,9010) element
         write(*,9020) eload_type
         write(*,9030) eload_dof
         write(*,9040) elval
         write(*,9050) eload_pist
         write(*,9070) mult_fact
      end if
c
c                    initialize loading flags for current element row
c
      etype    = iprops(1,element)
      nnode    = iprops(2,element)
      iorder   = iprops(5,element)
      ngp      = iprops(6,element)
      totdof   = nnode * 3
      geonl    = lprops(18,element)
      body_flg = .false.
      face_flg = .false.
      nrml_flg = .false.
      if (debug) write (*,*) '>>>>>> ELEMENT:' , element
      call get_single_edest_terms( edest, element )
c
      tet_elem = etype .eq. 6 .or. etype .eq. 13
c
c                    get the coordinates of nodes for the current element
c                         elem_nodes stores the structure node numbers
c                         for the element nodes; ecoord stores
c                         the coordinates for the element nodes.
c                         if we have geometric nonlinearity, then the
c                         current coordinates are the original coords
c                         (stored in c) plus the displacements (stored in
c                         u).
c
      if ( debug ) write (*,*) '     getting new coords'
      if ( geonl ) then
         do node = 1, nnode
            elem_nodes(node) = incid(incmap(element)+(node-1))
            ecoord(1,node) =
     &           c(crdmap(elem_nodes(node)))
     &           + u(edest(node))
            ecoord(2,node) =
     &           c(crdmap(elem_nodes(node))+1)
     &           + u(edest(nnode+node))
            ecoord(3,node) =
     &           c(crdmap(elem_nodes(node))+2)
     &           + u(edest(2*nnode+node))
         end do
      else
         do node = 1, nnode
            elem_nodes(node) = incid(incmap(element)+(node-1))
            ecoord(1,node) =
     &           c(crdmap(elem_nodes(node)))
            ecoord(2,node) =
     &           c(crdmap(elem_nodes(node))+1)
            ecoord(3,node) =
     &           c(crdmap(elem_nodes(node))+2)
         end do
      end if
      if ( debug ) write (*,*) '     done getting new coords'
c
c     build loading data variables.
c
      if ( eload_type .eq. 0 ) then
c
c                        1) body force -- build applied load vector
c
         body_flg    = .true.
         body_dir    = eload_dof
         body_intens = elval
         if ( debug ) then
            write(*,*) '    body force. element',element
            write(*,*) 'body_flg,body_dir,body_intens:'
            write(*,*)  body_flg,body_dir,body_intens
         end if
c
      else if ( eload_type .gt. 0 ) then
c
c                        2) face force constant direction
c
         face        = eload_type
         face_dir    = eload_dof
         face_intens = elval
         face_flg    = .true.
         if ( debug ) then
            write(*,*) '    face load, const. dir'
            write(*,*) 'face,face_dir,face_intens:'
            write(*,*) face,face_dir,face_intens
         end if
c
      else if ( eload_type .eq. -100 ) then
c
c                        3) element temperature. save temperature
c                           change in global vector
c
         if ( debug ) write (*,*) '    element temper'
         dtemp_elems(element) = dtemp_elems(element)+
     &        elval*mult_fact
         temperatures = .true.
c
      else if ( (eload_type .le. -7)
     &        .and. (eload_type .ge. -12 ) ) then
c
c                        4) piston theory pressure
c
         face       = abs(eload_type) - 6
         face_dir   = eload_dof
         face_flg    = .true.
         nrml_flg    = .true.
c
c                        call a separate subroutine piston loading
c                        parameters at current time. linearly interpolate
c                        between times listed in the table
c
         call interp_piston_params(
     &        p3, u3, m3, gam, fdirc, eload_pist, total_model_time )
c
c                        call a separate subroutine to determine the
c                        face_intens from piston theory
c
         call piston_face_intens(
     &        face_intens, element, etype, nnode, face,
     &        p3, u3, m3, gam, fdirc, tet_elem, elem_nodes,
     &        ecoord )
c
         if ( debug ) then
            write(*,*) '    face load, piston'
            write(*,*) 'face,face_dir,face_intens:'
            write(*,*) face,face_dir,face_intens
         end if
c
      else
c
c                        5) pressure force
c
         face        = abs(eload_type)
         face_dir    = eload_dof
         face_intens = elval
         face_flg    = .true.
         nrml_flg    = .true.
         if ( debug ) then
            write(*,*) '    face load, normal'
            write(*,*) 'face,face_dir,face_intens:'
            write(*,*) face,face_dir,face_intens
         end if
      end if
c
c                    now process the face and body forces if they have
c                    been set.
c
c                       1) compute body forces and add to structure
c                          incremental load vector (by nodal dof).
c
      if ( body_flg ) then
         if ( debug ) write (*,*) '  processing body forces.'
         call body_load( element, etype, nnode, body_dir,
     &        body_intens, ecoord, equiv_loads_ele )
c
         call elem_eqload_allocate( element, nnode )
         eforces => elem_eq_loads(element)%forces
c
         k = body_dir - 1
         do enode = 1, nnode
            snode = elem_nodes(enode)
            del_eqload(dstmap(snode)+k) = del_eqload(dstmap(snode)+k) +
     &           equiv_loads_ele(enode)*mult_fact
            eforces(body_dir,enode) = eforces(body_dir,enode) +
     &           equiv_loads_ele(enode)*mult_fact
         end do
      end if
c
c                       2) face/pressure forces
c
      if ( face_flg ) then
         if ( debug ) write (*,*) '  processing face/pressure loads.'
         do i = 1, nnode
            equiv_loads_face(i,1) = zero
            equiv_loads_face(i,2) = zero
            equiv_loads_face(i,3) = zero
         end do
         if ( .not. nrml_flg ) then
            call face_load( element, etype, nnode, face,
     &           face_intensities(1,1), ecoord,
     &           equiv_loads_face(1,face_dir),
     &           1, face_intens )
         end if
         if ( nrml_flg ) then
c
            if ( tet_elem ) then
               call tet_face_nloads( element, etype, nnode, face,
     &              face_intensities(1,1),
     &              face_intensities(1,2),
     &              face_intensities(1,3),
     &              face_intens, ecoord, failed )
            else
               call hex_face_nloads( element, etype, nnode, face,
     &              face_intensities(1,1),
     &              face_intensities(1,2),
     &              face_intensities(1,3),
     &              face_intens, ecoord, failed )
            end if
            if ( failed ) return
c
            call face_load( element, etype, nnode, face,
     &           face_intensities(1,1), ecoord,
     &           equiv_loads_face(1,1),
     &           2, dummy )
            call face_load( element, etype, nnode, face,
     &           face_intensities(1,2), ecoord,
     &           equiv_loads_face(1,2),
     &           2, dummy )
            call face_load( element, etype, nnode, face,
     &           face_intensities(1,3), ecoord,
     &           equiv_loads_face(1,3),
     &           2, dummy )
         end if
c
         call elem_eqload_allocate( element, nnode )
         eforces => elem_eq_loads(element)%forces
c
         do enode = 1, nnode
            snode = elem_nodes(enode)
            del_eqload(dstmap(snode)+0) = del_eqload(dstmap(snode)+0) +
     &           equiv_loads_face(enode,1)*mult_fact
            del_eqload(dstmap(snode)+1) = del_eqload(dstmap(snode)+1) +
     &           equiv_loads_face(enode,2)*mult_fact
            del_eqload(dstmap(snode)+2) = del_eqload(dstmap(snode)+2) +
     &                        equiv_loads_face(enode,3)*mult_fact
            eforces(1,enode) = eforces(1,enode) +
     &           equiv_loads_face(enode,1)*mult_fact
            eforces(2,enode) = eforces(2,enode) +
     &           equiv_loads_face(enode,2)*mult_fact
            eforces(3,enode) = eforces(3,enode) +
     &           equiv_loads_face(enode,3)*mult_fact
         end do
      end if
c
      if (debug) write(*,*) '>> Leaving do_elem_load'
c
 9010 format(4x,'element number:  ',7x,i5)
 9020 format(4x,'load type:       ',7x,i5)
 9030 format(4x,'load dof:        ',7x,i5)
 9040 format(4x,'eload_val:       ',9x,f10.6)
 9050 format(4x,'eload_pist: tab #',i5)
 9070 format(4x,'mult factor:     ',9x,f10.6)
      end
c
c
c ****************************************************************
c *                                                              *
c *          normal pressure decomposition for hex elements      *
c *                                                              *
c ****************************************************************
c
c
      subroutine hex_face_nloads( element, etype, nnode, face,
     &                        xload, yload, zload, face_intens,
     &                        ecoord, failed )
      implicit double precision (a-h,o-z)
c
      dimension  xload(*), yload(*), zload(*), ecoord(3,*)
      integer element, etype, face
      logical failed
c
c                local arrays
c
      double precision
     &    jacob, jacobi, nrmvec
c
      dimension dsf(32,3), jacob(3,3), jacobi(3,3),
     &          nrmvec(3), fnodes(10), fcoor(3,10)
      logical local_debug, bad
      integer enode, fnodes
      data zero, local_debug / 0.0, .false. /
c
c             get a list of element node numbers for the loaded
c             face and the isoparametric coordinates of nodes
c             on the face.
c
      failed = .false.
      do i = 1, nnode
        xload(i) = zero
        yload(i) = zero
        zload(i) = zero
      end do
      if ( local_debug ) write(*,1000) etype, face
      call eqelfn( fnodes, etype, face, nfnode )
      call ndpts1( fnodes, nfnode, fcoor, etype, -1, dum1, dum2, dum3 )
      if ( local_debug ) then
          write(*,1010) nfnode, (fnodes(i),i=1,nfnode )
          write(*,1020) ((fcoor(i,j),i=1,3),j=1,nfnode)
      end if
c
c             loop over all nodes on the loaded face:
c
c              1) evaluate derivatives of shape functions
c                 at the node;
c              2) compute the jacobian at the node;
c              3) select vectors veca,vecb that are in the tangent
c                 plane to the face at the node.  rows of the
c                 jacobian are components of the vectors.
c              4) construct an inward normal vector to the face
c                 (veca x vecb) and normalize to unit length
c                 thus producing direction cosines;
c              5) if the normal length <= a small tolerance, we probably
c                 have a corner node on a collased face. back off from
c                 the corner node by 10% in parametric space and try to
c                 compute normal again. if that fails, omit load
c                 computations for this face of this element and issue
c                 message
c              6) x,y,z components of load at the node are the
c                 pressure intensity * the corresponding direction
c                 cosine.
c
      do node = 1, nfnode
        xsi  = fcoor(1,node)
        eta  = fcoor(2,node)
        zeta = fcoor(3,node)
        call derivs( etype, xsi, eta, zeta, dsf(1,1), dsf(1,2),
     &               dsf(1,3) )
        call eqldjb( dsf, ecoord, nnode, jacob, jacobi, det, ierr )
        call eqnrmvh( face, jacob, nrmvec, bad, local_debug )
        if( bad ) then
          call eqnrmvh_adjust( face, xsi, eta, zeta )
          call derivs( etype, xsi, eta, zeta, dsf(1,1), dsf(1,2),
     &                 dsf(1,3) )
          call eqldjb( dsf, ecoord, nnode, jacob, jacobi, det, ierr )
          call eqnrmvh( face, jacob, nrmvec, bad, local_debug )
          if( bad ) then
           call iodevn( idummy, iout, dummy, 1 )
           write (iout,1050) face, element
           failed = .true.
           return
          end if
        end if
        enode        = fnodes(node)
        xload(enode) = face_intens * nrmvec(1)
        yload(enode) = face_intens * nrmvec(2)
        zload(enode) = face_intens * nrmvec(3)
        if ( local_debug ) write(*,1030) enode, nrmvec
      end do
c
      if ( local_debug ) write(*,1040) (i,xload(i),yload(i),zload(i),
     &                                  i = 1, nnode )
c
      return
c
 1000 format(2x, 'normal load components: ' ,//,
     &        5x, 'element type ',i3, 2x,'face ', i3 /)
 1010 format(' number of face nodes:',i3,
     &        /,2x,'face nodes:',2(/,2x,10i5) )
 1020 format( 2x,'face node coords:',20(/,2x,3f5.1) )
 1030 format('enode:',i3,2x,'nrmvec:',3f15.9 )
 1040 format(2x,'nodal load components: ',
     &        40(/,2x,i4,3f15.8) )
 1050 format('>>> WARNING: pressure load placed on face ',i1,' of ',
     &       'element ',i8,'.  This face',/,
     &       '             has at least one collapsed edge. Warp3D',
     & /,    '             cannot resolve the normal direction at',/,
     &       '             one or more nodes on the loaded face.',/,
     &       '             This loading ignored...',/)
c
       end
c ****************************************************************
c *                                                              *
c *          adjust parametric coordinates for node on collapsed *
c *          face of hex element                                 *
c *                                                              *
c ****************************************************************
c
c
      subroutine  eqnrmvh_adjust( face, xsi, eta, zeta )
      implicit none
c
      integer face
      double precision
     &  xsi, eta, zeta, pt9
      data pt9 / 0.9 /
c
      if( face .eq. 1 .or. face .eq. 2 ) then
        eta  = eta * pt9
        zeta = zeta * pt9
        return
      end if
      if( face .eq. 3 .or. face .eq. 4 ) then
        xsi  = xsi * pt9
        zeta = zeta * pt9
        return
      end if
      if( face .eq. 5 .or. face .eq. 6 ) then
        xsi  = xsi * pt9
        eta  = eta * pt9
        return
      end if
c
      return
      end
c ****************************************************************
c *                                                              *
c *          normal pressure decomposition for tet elements      *
c *                                                              *
c ****************************************************************
c
c
      subroutine tet_face_nloads( element, etype, nnode, face,
     &                        xload, yload, zload, face_intens,
     &                        ecoord, failed )
      implicit double precision (a-h,o-z)
c
      dimension  xload(*), yload(*), zload(*), ecoord(3,*)
      integer element, etype, face
      logical failed
c
c                local arrays
c
      double precision
     &    nrmvec, mag1, mag2, mag_max, vec1, vec2
c
      dimension dsf(32,3), temp_dsf(32,3),
     &          sf (32), temp_sf(32),
     &          nrmvec(3), vec1(3), vec2(3),
     &          fnodes(10), fcoor_tri6(3,6),
     &          fcoor_tri3(3,3)
      logical local_debug, etype_tet10, etype_tet4
      integer enode, fnodes, i
      data   zero, local_debug, tol
     &  / 0.d0, .false., 1.0d-06 /
c
c
c                    use shape function derivatives for triangular
c                    interface elements for tractions on the tet
c                    faces. this is done to avoid taking derivatives
c                    with respect to the dependent natural
c                    coordinate.
c
c                    because we're working in 2D, the isoparametric
c                    coordinates will be the same regardless of the
c                    face that is loaded.
c
c
      data fcoor_tri6
     & / 0.d0,  0.d0,  1.d0,
     &   0.5d0, 0.d0,  0.5d0,
     &   1.d0,  0.d0,  0.d0,
     &   0.5d0, 0.5d0, 0.d0,
     &   0.d0,  1.d0,  0.d0,
     &   0.d0,  0.5d0, 0.5d0 /
c
      data fcoor_tri3
     & / 0.d0, 0.d0, 1.d0,
     &   1.d0, 0.d0, 0.d0,
     &   0.d0, 1.d0, 0.d0 /
c
c
c                     determine if linear or quadratic tet
c
c
      failed      = .false.
      etype_tet10 = etype .eq. 6
      etype_tet4  = etype .eq. 13
c
c
      do i = 1, nnode
        xload(i) = zero
        yload(i) = zero
        zload(i) = zero
      end do
      if ( local_debug ) write(*,1000) etype, face
c
c
c                    get the tet nodes on the face for mapping
c                    derivatives to the correct nodal coordinates.
c
c
      call tet_get_nodes( fnodes, etype, face, nfnode )
c
c
c                    the index variable causes the 'derivs'
c                    routine to go to the correct tri
c                    derivatives.
c
c
      if( etype_tet4 ) then
        index = 14
      else if ( etype_tet10 ) then
        index = 15
      end if
c
c             loop over all nodes on the loaded face:
c
c              1) evaluate derivatives of shape functions
c                 at the node;
c              2) build vec1, vec2
c              3) construct an inward normal vector to the face
c                 (vec1 x vec2) and normalize to unit length
c                 thus producing direction cosines;
c              4) x,y,z components of load at the node are the
c                 pressure intensity * the corresponding direction
c                 cosine.
c
c
      do node = 1, nfnode
        if( etype_tet4 ) then
          index = 14
          call derivs( index, fcoor_tri3(1,node), fcoor_tri3(2,node),
     &                 fcoor_tri3(3,node), temp_dsf(1,1), temp_dsf(1,2),
     &                 temp_dsf(1,3) )
        else if( etype_tet10 ) then
          index = 15
          call derivs( index, fcoor_tri6(1,node), fcoor_tri6(2,node),
     &                 fcoor_tri6(3,node), temp_dsf(1,1), temp_dsf(1,2),
     &                 temp_dsf(1,3) )
        end if
        call map_tet_tri( etype, nfnode, fnodes, sf, temp_sf,
     &                    dsf, temp_dsf )
        call tet_darea( dsf, nfnode, fnodes, ecoord, darea,
     &                  vec1, vec2 )
c
c             check to see if either vector has zero length.
c
        mag1 = sqrt (vec1(1)**2 + vec1(2)**2 + vec1(3)**2 )
        mag2 = sqrt (vec2(1)**2 + vec2(2)**2 + vec2(3)**2 )
        mag_max = max( mag1, mag2 )
        if( mag_max .eq. zero ) then
           call iodevn( idummy, iout, dummy, 1 )
           write (iout,1050) face, element
           failed = .true.
           return
        end if
c
        mag1 = mag1 / mag_max
        mag2 = mag2 / mag_max
        if( mag1 .le. tol .or. mag2 .le. tol ) then
           call iodevn( idummy, iout, dummy, 1 )
           write (iout,1050) face, element
           failed = .true.
           return
        end if
c
c             generate unit normal to surface at node using
c             cross product of tangent plane vectors.
c             then compute x,y,z components of load.
c
        nrmvec(1) = vec1(2)*vec2(3) - vec2(2)*vec1(3)
        nrmvec(2) = vec2(1)*vec1(3) - vec1(1)*vec2(3)
        nrmvec(3) = vec1(1)*vec2(2) - vec2(1)*vec1(2)
        rlen = sqrt( nrmvec(1)*nrmvec(1) + nrmvec(2)*nrmvec(2) +
     &               nrmvec(3)*nrmvec(3) )
        nrmvec(1) = nrmvec(1) / rlen
        nrmvec(2) = nrmvec(2) / rlen
        nrmvec(3) = nrmvec(3) / rlen
c
        enode        = fnodes(node)
        xload(enode) = -face_intens * nrmvec(1)
        yload(enode) = -face_intens * nrmvec(2)
        zload(enode) = -face_intens * nrmvec(3)
        if ( local_debug ) write(*,1030) enode, nrmvec
      end do
c
      if ( local_debug ) write(*,1040) (i,xload(i),yload(i),zload(i),
     &                                  i = 1, nnode )
c
      return
c
 1000 format(2x, 'normal load components: ' ,//,
     &        5x, 'element type ',i3, 2x,'face ', i3 /)
 1010 format(' number of face nodes:',i3,
     &        /,2x,'face nodes:',2(/,2x,10i5) )
 1020 format( 2x,'face node coords:',20(/,2x,3f5.1) )
 1030 format('enode:',i3,2x,'nrmvec:',3f7.4 )
 1040 format(2x,'nodal load components: ',
     &        40(/,2x,i4,3f15.5) )
 1050 format('>>> WARNING: pressure load placed on face ',i1,' of ',
     &       'element ',i8,'.  This face',/,
     &       '             has at least one collapsed edge. Warp3D',
     & /,    '             cannot resolve the normal direction at',/,
     &       '             one or more nodes on the loaded face.',/,
     &       '             This loading ignored...',/)
c
       end

c
c ****************************************************************
c *                                                              *
c *          elem_load_allocate                                  *
c *                                                              *
c ****************************************************************
c
c
      subroutine elem_eqload_allocate( element, nnode )
      use main_data
c
      implicit integer (a-z)
      double precision
     & zero

      data zero / 0.0 /
c
      elem_equiv_loads_now = .true.
c
      if( elem_eq_loads(element)%ncols .eq. 0 ) then
        allocate( elem_eq_loads(element)%forces(3,nnode) )
        elem_eq_loads(element)%ncols = nnode
        do enode = 1, nnode
           elem_eq_loads(element)%forces(1:3,enode) = zero
        end do
      end if
c
      return
      end
c
c ****************************************************************
c *                                                              *
c *   normal vector for pressure decomposition - hex elements    *
c *                                                              *
c ****************************************************************
c
c
      subroutine eqnrmvh( face, jacob, nrmvec, bad, debug )
      implicit none
c
      double precision
     &  jacob(3,3), nrmvec(3)
      integer face
      logical bad, debug
c
c                local arrays
c
      double precision
     &     maga, magb, mag_max, veca(3), vecb(3), rlen,
     &     zero, tol, mag_min
      integer irowa(6), irowb(6), rowa, rowb
c
      data zero, tol / 0.0, 0.0001 /
      data irowa /  2,3,3,1,1,2 /
      data irowb /  3,2,1,3,2,1 /
c
      bad     = .false.
      rowa    = irowa(face)
      rowb    = irowb(face)
      veca(1) = jacob(rowa,1)
      veca(2) = jacob(rowa,2)
      veca(3) = jacob(rowa,3)
      vecb(1) = jacob(rowb,1)
      vecb(2) = jacob(rowb,2)
      vecb(3) = jacob(rowb,3)
c      write(*,*) '... eqnrmvh ...'
c      write(*,9900) veca, vecb

c
c             Error conditions:
c               (1) either vector has exactly zero length
c               (2) shorter vector length is < tol2 * longer
c                   vector length
c
        maga = sqrt (veca(1)**2 + veca(2)**2 + veca(3)**2 )
        magb = sqrt (vecb(1)**2 + vecb(2)**2 + vecb(3)**2 )
        mag_max = maga
        mag_min = magb
c        write(*,9910) maga, magb
        if( magb .gt. maga ) then
          mag_max = magb
          mag_min = maga
        end if
        if( (mag_min .eq. zero) .or.
     &      (mag_min .lt. tol*mag_max) ) then
           bad = .true.
           return
        end if
        if( debug ) then
          write(*,*) '..normal vector computation..'
          write(*,*) '   rowa, rowb: ', rowa, rowb
          write(*,9000) jacob(1,1:3), jacob(2,1:3),
     &           jacob(3,1:3)
 9000     format(3(5x,3f15.9,/) )
          write(*,*) '    maga, magb: ', maga, magb
        end if
c
c             generate unit normal to surface at node using
c             cross product of tangent plane vectors.
c             then compute x,y,z components of load.
c
c             colinear or nearly colinear vectors lead
c             to zero or nearly zero length of cross
c             product vector
c
c             separately, veca and vecb are ok. normalize them
c             before taking cross product.
c             length of the cross-product (normal) vector is then
c             a good measure of the colinearity of veca and
c             vecb.
c
        veca(1:3) = veca(1:3) / maga
        vecb(1:3) = vecb(1:3) / magb
        nrmvec(1) = veca(2)*vecb(3) - vecb(2)*veca(3)
        nrmvec(2) = vecb(1)*veca(3) - veca(1)*vecb(3)
        nrmvec(3) = veca(1)*vecb(2) - vecb(1)*veca(2)
        rlen = sqrt( nrmvec(1)*nrmvec(1) + nrmvec(2)*nrmvec(2) +
     &               nrmvec(3)*nrmvec(3) )
c        if( debug ) then
c         write(*,9920) nrmvec, rlen
c        end if
        if( rlen .lt. tol*10.0 ) then
           bad = .true.
           return
        end if
c
        nrmvec(1) = nrmvec(1) / rlen
        nrmvec(2) = nrmvec(2) / rlen
        nrmvec(3) = nrmvec(3) / rlen
c
        return
 9900   format(3x, 'veca: ',3e14.6,/,/,3x, 'vecb: ',3e14.6)
 9910   format(3x,'maga, magb: ', 2e14.6)
 9920   format(3x,'nrmvec: ',3e14.6,' rlen: ',e14.6)

        end
c
c
c ****************************************************************
c *                                                              *
c *          interp_piston_params                                *
c *                                                              *
c ****************************************************************
c
c
      subroutine interp_piston_params(
     &     p3, u3, m3, gam, fdirc, tabn, cmptime )
      use main_data, only: tables
c
      implicit integer (a-z)
c
c     parameter declarations
c     ----------------------
c
      double precision
     &     p3, u3, m3, gam, fdirc(3), cmptime
c
c     declare local variables
c     -----------------------
c
      double precision
     &     t0, tf, tn, ti, pn, un, mn, gn, fn(3),
     &     tn1, pn1, un1, mn1, gn1, fn1(3), one, fac1, fac2,
     &     mx, my, mz, norm
      logical debug
      data zero, one, debug / 0.0d0, 1.0d0, .false. /
c
      if (debug) write (*,*) ' >>>>> inside of interp_piston_params'
c
c                 initialize number of rows in the table
c
      nrows = tables(tabn)%num_rows
c
c                 check if cmptime is either at the beginning
c                 of the end of the loading history, if so
c                 no need for interpolatation. set parameters and
c                 return to calling function
c
      t0  = tables(tabn)%table_values_sgl(1,1)
      tf  = tables(tabn)%table_values_sgl(nrows,1)
      if (debug) write(*,9000) cmptime, tabn, t0, tf
c
      if ( cmptime .eq. t0 ) then
         if (debug) write(*,9010)
         p3       = tables(tabn)%table_values_sgl(1,2)
         u3       = tables(tabn)%table_values_sgl(1,3)
         m3       = tables(tabn)%table_values_sgl(1,4)
         gam      = tables(tabn)%table_values_sgl(1,5)
         fdirc(1) = tables(tabn)%table_values_sgl(1,6)
         fdirc(2) = tables(tabn)%table_values_sgl(1,7)
         fdirc(3) = tables(tabn)%table_values_sgl(1,8)
         go to 9999
      end if
c
      if ( cmptime .gt. tf ) then
         if (debug) write(*,9020)
         p3       = tables(tabn)%table_values_sgl(nrows,2)
         u3       = tables(tabn)%table_values_sgl(nrows,3)
         m3       = tables(tabn)%table_values_sgl(nrows,4)
         gam      = tables(tabn)%table_values_sgl(nrows,5)
         fdirc(1) = tables(tabn)%table_values_sgl(nrows,6)
         fdirc(2) = tables(tabn)%table_values_sgl(nrows,7)
         fdirc(3) = tables(tabn)%table_values_sgl(nrows,8)
         go to 9999
      end if
c
c                 need to linearly interpolate to determine
c                 piston parameters. search for time interval
c                 that cmptime falls into then perform interpolation
c
      do row = 2,nrows
         tn1 = tables(tabn)%table_values_sgl(row,1)
c
c                 time increase monotonically. search for
c                 row where defined time is greater than current
c                 time
c
         if ( .not. ( tn1 .gt. cmptime ) ) cycle
         tn  = tables(tabn)%table_values_sgl(row-1,1)
         ti = cmptime - tn
         fac1 = one - ti/(tn1-tn)
         fac2 = ti/(tn1-tn)
c
         if (debug)
     &        write(*,9030) tn, tn1, ti, fac1, fac2
c
c                 get piston paramters at tn and tn1
c
         pn     = tables(tabn)%table_values_sgl(row-1,2)
         un     = tables(tabn)%table_values_sgl(row-1,3)
         mn     = tables(tabn)%table_values_sgl(row-1,4)
         gn     = tables(tabn)%table_values_sgl(row-1,5)
         fn(1)  = tables(tabn)%table_values_sgl(row-1,6)
         fn(2)  = tables(tabn)%table_values_sgl(row-1,7)
         fn(3)  = tables(tabn)%table_values_sgl(row-1,8)
c
         pn1    = tables(tabn)%table_values_sgl(row,2)
         un1    = tables(tabn)%table_values_sgl(row,3)
         mn1    = tables(tabn)%table_values_sgl(row,4)
         gn1    = tables(tabn)%table_values_sgl(row,5)
         fn1(1) = tables(tabn)%table_values_sgl(row,6)
         fn1(2) = tables(tabn)%table_values_sgl(row,7)
         fn1(3) = tables(tabn)%table_values_sgl(row,8)
c
c                 perform interpolation, ensure that flow
c                 direction vectors have a unit normal
c
         p3  = fac1*pn + fac2*pn1
         u3  = fac1*un + fac2*un1
         m3  = fac1*mn + fac2*mn1
         gam = fac1*gn + fac2*gn1
         mx  = fac1*fn(1) + fac2*fn1(1)
         my  = fac1*fn(2) + fac2*fn1(2)
         mz  = fac1*fn(3) + fac2*fn1(3)
c
         norm = sqrt( mx*mx + my*my + mz*mz )
         if ( norm .eq. zero ) then
            call errmsg(340,dum,dums,dumr,dumd)
         end if
c
         fdirc(1) = mx/norm
         fdirc(2) = my/norm
         fdirc(3) = mz/norm
c
         go to 9999
      end do
c
 9999 continue
      if (debug) write(*,9040) p3, u3, m3, gam, (fdirc(k),k=1,3)
      if (debug) write(*,*) ' >>>>> leaving of interp_piston_params'
c
      return
 9000 format(3x,'Current time         ',f13.6,/,
     &       3x,'Table number:        ',i6,/,
     &       3x,'Initial time:        ',f13.6,/,
     &       3x,'Final time:          ',f13.6 )
 9010 format(3x,'Using piston parameters at initial time.'/)
 9020 format(3x,'Using piston parameters at final time.'/)
 9030 format(3x,'Current time between ',f13.6,' and ',f13.6,/,
     &       3x,'Interpolation factors',3f13.6,/)
 9040 format(3x,'p3,   u3:   ',4x,2f13.6,/,
     &       3x,'m3,   gam:  ',4x,2f13.6,/,
     &       3x,'flow direction: ',3f13.6,/)
c
      end


!   Copyright 2014 College of William and Mary
!
!   Licensed under the Apache License, Version 2.0 (the "License");
!   you may not use this file except in compliance with the License.
!   You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
!   Unless required by applicable law or agreed to in writing, software
!   distributed under the License is distributed on an "AS IS" BASIS,
!   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!   See the License for the specific language governing permissions and
!   limitations under the License.

! Generate hotstart.nc, and *[23]D.th.nc from gridded HYCOM data (nc file)
! The section on nc read needs to be modified as appropriate- search for
! 'start11' and 'end11'
! Beware the order of vertical levels in the nc file!!!
! Assume elev=0 in interpolation of 3D variables
! The code will do all it can to extrapolate: below bottom/above surface.
! If a pt in hgrid.ll is outside the background nc grid, const. values will be filled (from gen_hot_3Dth_from_nc.in)
!
! Dan Yu: added checking vertical layer for each 3D var from HYCOM nc, and some easy remedy for nc file error
! Wet-dry points are defined by ssh.
! For U,V, if junk values in the middle of water, simply fill with 0 and record in fort.20
! For S,T, if junk values in the middle of water, simply fill with bottom value, and record in fort.20
! If SSH shows wet/dry in time, search nearby points to fill. If none found, fill 0, and record in fort.20
! Consider checking HYCOM nc files with ncview or other tools.

!   Input:
!     (1) hgrid.gr3;
!     (2) hgrid.ll;
!     (3) vgrid.in (SCHISM R1703 and up);
!     (4) estuary.gr3 (flags for extrapolating S,T, vel.): depth=0: outside; =1: inside
!     (5) gen_hot_3Dth_from_nc.in:
!                     1st line: 1: include vel and elev. in hotstart.nc (and *[23D].th will start from non-0 values); 0: only T,S
!                     2nd line: T,S values for estuary points defined in estuary.gr3
!                     3rd line: T,S values for pts outside bg grid in nc
!                     4th line: time step in .nc in sec
!                     5th line: nob, iob(1:nob) - # of open bnd seg's that need
!                               *[23D].th; list of seg IDs. All *[23D].th must share same set of bnd seg's
!                     6th line: # of days needed
!                     7th line: # of HYCOM file stacks
!     (6) HYCOM files: [SSH,TS,UV]_[1,2,..nfiles].nc (beware scaling etc)
!   Output: hotstart.nc; *[23D].th.nc
!   Debug outputs: fort.11 (fatal errors); fort.20 (warning); fort.2[1-9], fort.9[5-9], fort.100; backup.out
!   Use note: if the domain is large and you wish to download HYCOM
!   fast, you may want to run this script twice: first to generate
!   hotstart only (so you need only to download a few HYCOM files); the
!   .th.nc are junk in this step.
!   Second, download HYCOM to only cover the open boundary segments to
!   generate .th.nc (hotstart would be junk).

! ifort -O2 -mcmodel=medium -assume byterecl -CB -o gen_hot_3Dth_from_hycom.exe ../UtilLib/schism_geometry.f90 \
! ../UtilLib/extract_mod.f90 ../UtilLib/compute_zcor.f90 ../UtilLib/pt_in_poly_test.f90 gen_hot_3Dth_from_hycom.f90 \
!-I$NETCDF/include -I$NETCDF_FORTRAN/include -L$NETCDF_FORTRAN/lib -L$NETCDF/lib -lnetcdf -lnetcdff

      program gen_hot
      use netcdf
      use schism_geometry_mod
      use compute_zcor
      use pt_in_poly_test, only: signa_single

!      implicit none

!      integer, parameter :: debug=1
!      integer, parameter :: mnp=480000*6
!      integer, parameter :: mne=960000*6
!      integer, parameter :: mns=1440000*6
!      integer, parameter :: mnv=50
!      integer, parameter :: mnope=10 !max # of open bnd segments
!      integer, parameter :: mnond=5000 !max # of open bnd nodes in each segment
!      integer, parameter :: mnei=20 !neighbor
      integer, parameter :: nbyte=4
      real, parameter :: small1=1.e-2 !used to check area ratios

!     netcdf related variables
      integer :: sid, ncids(100) ! Netcdf file IDs
      integer :: latvid, lonvid, zmvid, hvid ! positional variables
      integer :: xdid, xvid ! longitude index
      integer :: ydid, yvid ! latitude index
      integer :: ldid, lvid ! vertical level, 1 is top
      integer :: svid, tvid ! salt & temp variable IDs
      integer :: uvid, vvid ! vel variable IDs
      integer :: evid ! SSH variable IDs
      integer :: one_dim,ivarid(100),var1d_dims(1),var2d_dims(2),var3d_dims(3), &
     &var4d_dims(4),itime_id(4)
      integer, dimension(nf90_max_var_dims) :: dids

!     Local variables for data
      real (kind = 4), allocatable :: xind(:), yind(:), lind(:)
!     Lat, lon, bathymetry
      real (kind = 4), allocatable :: lat(:,:), lon(:,:), hnc(:)
!     Vertical postion, salinity, and temperature
      real (kind = 4), allocatable :: zm(:,:,:),salt(:,:,:),temp(:,:,:), &
     &uvel(:,:,:),vvel(:,:,:),ssh(:,:),salt0(:,:,:),temp0(:,:,:),uvel0(:,:,:),vvel0(:,:,:),ssh0(:,:)
      integer, allocatable :: kbp(:,:),ihope(:,:)
!     File names for netcdf files
      character(len=1024) :: ncfile1
!     Command line arguments
      character(len=1024) :: s, yr, md
      character(len=4) :: iyear_char
      character(len=1) :: char1,char2
      character(len=20) :: char3,char4
!     external function for number of command line arguments
!      integer :: iargc

      integer :: status ! netcdf local status variable
      integer :: ier ! allocate error return.
      integer :: ixlen, iylen, ilen ! sampled lengths in each coordinate direction
      integer :: ixlen1, iylen1,ixlen2, iylen2 !reduced indices for CORIE grid to speed up interpolation
      integer :: klev(4)
      real :: wild(100),wild2(100,2)

      integer, allocatable :: elnode(:,:),elside(:,:),isdel(:,:),idry_s(:),i34(:),iest(:), &
     &ixy(:,:),ic3(:,:),isidenode(:,:),nond(:),iond(:,:),iob(:),iond2(:)
      !integer :: indel(mnei,mnp),idry_s(mns)
      !integer :: idry_s(mns)
      real, allocatable :: xl(:),yl(:),dp(:),ztot(:),sigma(:),arco(:,:), &
     &tempout(:,:),saltout(:,:),uout(:,:),vout(:,:),eout(:),su2(:,:),sv2(:,:), &
     &eout_tmp(:),tsel(:,:,:),zeros(:,:),xcj(:),ycj(:)
!      dimension ztot(0:mnv),sigma(mnv),cs(mnv),arco(4,mnp)
!      dimension tempout(mnv,mnp), saltout(mnv,mnp) !,month_day(12)
!      dimension uout(mnv,mnp),vout(mnv,mnp),eout(mnp),su2(mns,mnv),sv2(mns,mnv),eout_tmp(mnp)
!      dimension tsel(2,mnv,mne),zeros(mnv,max(mne,mnp))
!      dimension xcj(mns),ycj(mns) !,nond(mnope),iond(mnope,mnond),iob(mnope),iond2(mnope*mnond)
      allocatable :: z(:,:),sigma_lcl(:,:),kbp2(:),iparen_of_dry(:,:)
      real*8 :: aa1(1)

!     First statement
!     Currently we assume rectangular grid in HYCOM
!     (interp_mode=0). interp_mode=1 uses generic UG search (splitting
!     quads) and is kept for more generic cases
      interp_mode=0

      open(10,file='gen_hot_3Dth_from_nc.in',status='old')
      read(10,*) iuv !1: include vel and elev. in hotstart.in; 0: only T,S
      read(10,*) tem_es,sal_es !T,S values for estuary points defined in estuary.gr3
      read(10,*) tem_outside,sal_outside !T,S values for pts outside bg grid in nc
      read(10,*) dtout !time step in .nc [sec]
      read(10,*) nob !,iob(1:nob) !# of open bnds that need *3D.th; list of IDs
      read(10,*) nndays !# of days needed in output
      read(10,*) nfiles !# of stacks of HYCOM files

      allocate(iob(nob))
      rewind(10)
      do i=1,4; read(10,*); enddo
      read(10,*) nob,iob(1:nob)
      close(10)
      if(tem_es<0.or.sal_es<0.or.tem_outside<0.or.sal_outside<0) &
     &stop 'Invalid T,S constants'

!     Read in hgrid and vgrid
      open(17,file='estuary.gr3',status='old')
      open(16,file='hgrid.ll',status='old')
      open(14,file='hgrid.gr3',status='old') !only need depth info and connectivity
      open(19,file='vgrid.in',status='old')
      open(11,file='fort.11',status='replace')
      read(14,*)
      read(14,*)ne,np
      allocate(xl(np),yl(np),dp(np),i34(ne),elnode(4,ne),iest(np),ixy(np,3),stat=istat)
      if(istat/=0) stop 'Failed to alloc. (0)'
      read(16,*)
      read(16,*)
      read(17,*)
      read(17,*)
      do i=1,np
        read(14,*)j,xtmp,ytmp,dp(i)
        read(16,*)j,xl(i),yl(i)
        read(17,*)j,xtmp,ytmp,tmp
        iest(i)=nint(tmp)
        if(iest(i)/=0.and.iest(i)/=1) then
          write(11,*)'Estuary flag wrong:',i,iest(i)
          stop
        endif
      enddo !i
      do i=1,ne
        read(14,*)j,i34(i),(elnode(l,i),l=1,i34(i))
      enddo !i
!     Open bnds
      read(14,*) nope
      read(14,*) neta
      ntot=0
      allocate(nond(max(1,nope)))
!      if(nope>mnope) stop 'Increase mnope (2)'
      do k=1,nope
        read(14,*) nond(k)
        do i=1,nond(k)
          read(14,*) !iond(k,i)
        enddo
      enddo

      rewind(14)
      mnope=maxval(nond)
      if(mnope<=0) stop 'need open bnd'
      allocate(iond(mnope,nope),iond2(mnope*nope))
      do i=1,2+np+ne+2; read(14,*); enddo
      do k=1,nope
        read(14,*) !nond(k)
        do i=1,nond(k)
          read(14,*)iond(i,k)
        enddo
      enddo
      close(14)

      nond0=0
      do i=1,nob
        ibnd=iob(i)
        do j=1,nond(ibnd)
          nond0=nond0+1
          iond2(nond0)=iond(j,ibnd)
        enddo !j
      enddo !i

      close(16)

!     V-grid
      read(19,*)ivcor
      read(19,*)nvrt
!      if(nvrt>mnv) stop 'increase mnv'
      rewind(19)
      allocate(sigma_lcl(nvrt,np),z(nvrt,np),kbp2(np),ztot(0:nvrt),sigma(nvrt),arco(4,np), &
     &tempout(nvrt,np),saltout(nvrt,np),uout(nvrt,np),vout(nvrt,np),eout(np), &
     &eout_tmp(np),tsel(2,nvrt,ne),zeros(nvrt,max(ne,np)),stat=istat)
      if(istat/=0) stop 'Failed to alloc. (1)'
      call get_vgrid_single('vgrid.in',np,nvrt,ivcor,kz,h_s,h_c,theta_b,theta_f,ztot,sigma,sigma_lcl,kbp2)

!     Compute z-coord.
      do i=1,np
        if(ivcor==2) then
          call zcor_SZ_single(max(0.11,dp(i)),0.,0.1,h_s,h_c,theta_b,theta_f,kz,nvrt,ztot,sigma,z(:,i),idry,kbp2(i))
        else if(ivcor==1) then
          z(kbp2(i):nvrt,i)=max(0.11,dp(i))*sigma_lcl(kbp2(i):nvrt,i)
        else
          write(11,*)'Unknown ivcor:',ivcor
          stop
        endif

        !Extend below bottom for interpolation later
        z(1:kbp2(i)-1,i)=z(kbp2(i),i)
      enddo !i

!     Compute geometry
      call compute_nside(np,ne,i34,elnode,ns)
      allocate(ic3(4,ne),elside(4,ne),isdel(2,ns),isidenode(2,ns),xcj(ns),ycj(ns), &
     &idry_s(ns),su2(nvrt,ns),sv2(nvrt,ns),stat=istat)
      if(istat/=0) stop 'Failed to alloc. (2)'

      call schism_geometry_single(np,ne,ns,xl,yl,i34,elnode,ic3,elside,isdel,isidenode,xcj,ycj)

!      do k=3,4
!        do i=1,k
!          do j=1,k-1
!            nx(k,i,j)=i+j
!            if(nx(k,i,j)>k) nx(k,i,j)=nx(k,i,j)-k
!            if(nx(k,i,j)<1.or.nx(k,i,j)>k) then
!              write(*,*)'nx wrong',i,j,k,nx(k,i,j)
!              stop
!            endif
!          enddo !j
!        enddo !i
!      enddo !k
!
!      do i=1,np
!        nne(i)=0
!      enddo
!
!      do i=1,ne
!        do j=1,i34(i)
!          nd=elnode(j,i)
!          nne(nd)=nne(nd)+1
!          if(nne(nd)>mnei) then
!            write(11,*)'Too many neighbors',nd
!            stop
!          endif
!          indel(nne(nd),nd)=i
!        enddo
!      enddo
!
!!     Compute ball info; this won't be affected by re-arrangement below
!      do i=1,ne
!        do j=1,i34(i)
!          ic3(j,i)=0 !index for bnd sides
!          nd1=elnode(nx(i34(i),j,1),i)
!          nd2=elnode(nx(i34(i),j,2),i)
!          do k=1,nne(nd1)
!            ie=indel(k,nd1)
!            if(ie/=i.and.(elnode(1,ie)==nd2.or.elnode(2,ie)==nd2.or.elnode(3,ie)==nd2.or.(i34(ie)==4.and.elnode(4,ie)==nd2))) ic3(j,i)=ie
!          enddo !k
!        enddo !j
!      enddo !i
!
!      ns=0 !# of sides
!      do i=1,ne
!        do j=1,i34(i)
!          nd1=elnode(nx(i34(i),j,1),i)
!          nd2=elnode(nx(i34(i),j,2),i)
!          if(ic3(j,i)==0.or.i<ic3(j,i)) then !new sides
!            ns=ns+1
!            if(ns>mns) then
!              write(11,*)'Too many sides'
!              stop
!            endif
!            elside(j,i)=ns
!            isdel(1,ns)=i
!            isidenode(1,ns)=nd1
!            isidenode(2,ns)=nd2
!            xcj(ns)=(xl(nd1)+xl(nd2))/2
!            ycj(ns)=(yl(nd1)+yl(nd2))/2
!!            dps(ns)=(dp(nd1)+dp(nd2))/2
!!            distj(ns)=dsqrt((x(nd2)-x(nd1))**2+(y(nd2)-y(nd1))**2)
!!            if(distj(ns)==0) then
!!              write(11,*)'Zero side',ns
!!              stop
!!            endif
!!            thetan=datan2(x(nd1)-x(nd2),y(nd2)-y(nd1))
!!            snx(ns)=dcos(thetan)
!!            sny(ns)=dsin(thetan)
!
!            isdel(2,ns)=ic3(j,i) !bnd element => bnd side
!!           Corresponding side in element ic3(j,i)
!            if(ic3(j,i)/=0) then !old internal side
!              iel=ic3(j,i)
!              index=0
!              do k=1,i34(iel)
!                if(ic3(k,iel)==i) then
!                  index=k
!                  exit
!                endif
!              enddo !k
!              if(index==0) then
!                write(11,*)'Wrong ball info',i,j
!                stop
!              endif
!              elside(index,iel)=ns
!            endif !ic3(j,i).ne.0
!          endif !ic3(j,i)==0.or.i<ic3(j,i)
!        enddo !j=1,i34
!      enddo !i=1,ne
!
      if(ns<ne.or.ns<np) then
        write(11,*)'Weird grid with ns < ne or ns < np',np,ne,ns
        stop
      endif
     print*, 'Done computing geometry...'

!     open(54,file='elev2D.th',access='direct',recl=nbyte*(1+nond0),status='replace')
!     open(55,file='uv3D.th',access='direct',recl=nbyte*(1+nond0*nvrt*2),status='replace')
!     open(56,file='TEM_3D.th',access='direct',recl=nbyte*(1+nond0*nvrt),status='replace')
!     open(57,file='SAL_3D.th',access='direct',recl=nbyte*(1+nond0*nvrt),status='replace')

      iret=nf90_create('elev2D.th.nc',OR(NF90_NETCDF4,NF90_CLOBBER),ncids(5))
      iret=nf90_def_dim(ncids(5),'nOpenBndNodes',nond0,nond0_dim)
      iret=nf90_def_dim(ncids(5),'one',1,one_dim)
      iret=nf90_def_dim(ncids(5),'time', NF90_UNLIMITED,itime_dim)
      iret=nf90_def_dim(ncids(5),'nLevels',1,nvrt_dim)
      iret=nf90_def_dim(ncids(5),'nComponents',1,ivs_dim)
      var1d_dims(1)=one_dim
      iret=nf90_def_var(ncids(5),'time_step',NF90_FLOAT,var1d_dims,idt)
      var1d_dims(1)=itime_dim
      iret=nf90_def_var(ncids(5),'time',NF90_DOUBLE,var1d_dims,itime_id(1))
      var4d_dims(1)=ivs_dim; var4d_dims(2)=nvrt_dim; var4d_dims(3)=nond0_dim
      var4d_dims(4)=itime_dim
      iret=nf90_def_var(ncids(5),'time_series',NF90_FLOAT,var4d_dims,ivarid(51))
      iret=nf90_enddef(ncids(5))
      iret=nf90_put_var(ncids(5),idt,dtout)

      iret=nf90_create('uv3D.th.nc',OR(NF90_NETCDF4,NF90_CLOBBER),ncids(6))
      iret=nf90_def_dim(ncids(6),'nOpenBndNodes',nond0,nond0_dim)
      iret=nf90_def_dim(ncids(6),'one',1,one_dim)
      iret=nf90_def_dim(ncids(6),'time', NF90_UNLIMITED,itime_dim)
      iret=nf90_def_dim(ncids(6),'nLevels',nvrt,nvrt_dim)
      iret=nf90_def_dim(ncids(6),'nComponents',2,ivs_dim)
      var1d_dims(1)=one_dim
      iret=nf90_def_var(ncids(6),'time_step',NF90_FLOAT,var1d_dims,idt)
      var1d_dims(1)=itime_dim
      iret=nf90_def_var(ncids(6),'time',NF90_DOUBLE,var1d_dims,itime_id(2))
      var4d_dims(1)=ivs_dim; var4d_dims(2)=nvrt_dim; var4d_dims(3)=nond0_dim
      var4d_dims(4)=itime_dim
      iret=nf90_def_var(ncids(6),'time_series',NF90_FLOAT,var4d_dims,ivarid(52))
      iret=nf90_enddef(ncids(6))
      iret=nf90_put_var(ncids(6),idt,dtout)

      iret=nf90_create('TEM_3D.th.nc',OR(NF90_NETCDF4,NF90_CLOBBER),ncids(7))
      iret=nf90_def_dim(ncids(7),'nOpenBndNodes',nond0,nond0_dim)
      iret=nf90_def_dim(ncids(7),'one',1,one_dim)
      iret=nf90_def_dim(ncids(7),'time', NF90_UNLIMITED,itime_dim)
      iret=nf90_def_dim(ncids(7),'nLevels',nvrt,nvrt_dim)
      iret=nf90_def_dim(ncids(7),'nComponents',1,ivs_dim)
      var1d_dims(1)=one_dim
      iret=nf90_def_var(ncids(7),'time_step',NF90_FLOAT,var1d_dims,idt)
      var1d_dims(1)=itime_dim
      iret=nf90_def_var(ncids(7),'time',NF90_DOUBLE,var1d_dims,itime_id(3))
      var4d_dims(1)=ivs_dim; var4d_dims(2)=nvrt_dim; var4d_dims(3)=nond0_dim
      var4d_dims(4)=itime_dim
      iret=nf90_def_var(ncids(7),'time_series',NF90_FLOAT,var4d_dims,ivarid(53))
      iret=nf90_enddef(ncids(7))
      iret=nf90_put_var(ncids(7),idt,dtout)

      iret=nf90_create('SAL_3D.th.nc',OR(NF90_NETCDF4,NF90_CLOBBER),ncids(8))
      iret=nf90_def_dim(ncids(8),'nOpenBndNodes',nond0,nond0_dim)
      iret=nf90_def_dim(ncids(8),'one',1,one_dim)
      iret=nf90_def_dim(ncids(8),'time', NF90_UNLIMITED,itime_dim)
      iret=nf90_def_dim(ncids(8),'nLevels',nvrt,nvrt_dim)
      iret=nf90_def_dim(ncids(8),'nComponents',1,ivs_dim)
      var1d_dims(1)=one_dim
      iret=nf90_def_var(ncids(8),'time_step',NF90_FLOAT,var1d_dims,idt)
      var1d_dims(1)=itime_dim
      iret=nf90_def_var(ncids(8),'time',NF90_DOUBLE,var1d_dims,itime_id(4))
      var4d_dims(1)=ivs_dim; var4d_dims(2)=nvrt_dim; var4d_dims(3)=nond0_dim
      var4d_dims(4)=itime_dim
      iret=nf90_def_var(ncids(8),'time_series',NF90_FLOAT,var4d_dims,ivarid(54))
      iret=nf90_enddef(ncids(8))
      iret=nf90_put_var(ncids(8),idt,dtout)

      open(12,file='backup.out',status='replace')

!start11
!     Set time step # (must be in 1st stack) corresponding to t=0
      it0=1

!     Define limits for variables for sanity checks
      tempmin=-10
      tempmax=40
      saltmin=0
      saltmax=45
      vmag_max=10 !max. |u| or |v|
      ssh_max=5 !max. of |SSH|

!     Assuming elev, u,v, S,T have same dimensions (and time step) and grids do not change over time
      timeout=0
      irecout=1
      do ifile=1,nfiles
!--------------------------------------------------------------------
      write(char3,'(i20)')ifile
      char3=adjustl(char3); len_char3=len_trim(char3)
!     Open nc file
      status = nf90_open('TS_'//char3(1:len_char3)//'.nc', nf90_nowrite, sid)
      call check(status)
      status = nf90_open('SSH_'//char3(1:len_char3)//'.nc', nf90_nowrite, ncids(1))
      status = nf90_open('UV_'//char3(1:len_char3)//'.nc', nf90_nowrite, ncids(2))

      if(ifile==1) then
!       Get dimnesions from S
        status = nf90_inq_varid(sid, "salinity", svid)
        print*, 'Done reading variable ID'
        print*, sid,svid,ncids(1:2),'TS_'//char3(1:len_char3)//'.nc'

!       Get dimensions from the 1st file
!       Assumed same as for all variables
!       WARNING: indices reversed from ncdump!
        status = nf90_Inquire_Variable(sid, svid, dimids = dids)
        status = nf90_Inquire_Dimension(sid, dids(1), len = ixlen)
        status = nf90_Inquire_Dimension(sid, dids(2), len = iylen)
        status = nf90_Inquire_Dimension(sid, dids(3), len = ilen)
        status = nf90_Inquire_Dimension(sid, dids(4), len = ntime)
        print*, dids(1),dids(2),dids(3),dids(4)
        print*, 'ixlen,iylen,ilen,ntime= ',ixlen,iylen,ilen,ntime

!       allocate arrays
        allocate(xind(ixlen),stat=ier)
        allocate(yind(iylen),stat=ier)
        allocate(lind(ilen),stat=ier)
        allocate(lat(ixlen,iylen))
        allocate(lon(ixlen,iylen))
        allocate(zm(ixlen, iylen, ilen))
!        allocate(hnc(ixlen,iylen))
        allocate(hnc(ilen))
        allocate(kbp(ixlen,iylen))
        allocate(ihope(ixlen,iylen))
        allocate(uvel(ixlen,iylen,ilen),stat=ier)
        allocate(vvel(ixlen,iylen,ilen),stat=ier)
        allocate(salt(ixlen,iylen,ilen),stat=ier)
        allocate(temp(ixlen,iylen,ilen),stat=ier)
        allocate(ssh(ixlen,iylen),stat=ier)
!        allocate(uvel0(ixlen,iylen,ilen),stat=ier)
!        allocate(vvel0(ixlen,iylen,ilen),stat=ier)
!        allocate(ssh0(ixlen,iylen),stat=ier)
!        allocate(salt0(ixlen,iylen,ilen),stat=ier)
!        allocate(temp0(ixlen,iylen,ilen),stat=ier)
        uvel=0; vvel=0; ssh=0

!       get static info (lat/lon grids etc)
        status = nf90_inq_varid(ncids(1), "xlon", xvid)
        status = nf90_get_var(ncids(1), xvid, xind)
        status = nf90_inq_varid(ncids(1), "ylat", yvid)
        status = nf90_get_var(ncids(1), yvid, yind)
        !lind may be sigma coord.
!        status = nf90_inq_varid(sid, "sigma", lvid)
!        status = nf90_get_var(sid, lvid, lind)
        status = nf90_inq_varid(sid, "depth", hvid)
        status = nf90_get_var(sid, hvid, hnc)

!       processing static info
        do i=1,ixlen
          lon(i,:)=xind(i)
          if(i<ixlen) then; if(xind(i)>=xind(i+1)) then
            write(11,*)'Lon must be increasing:',i,xind(i),xind(i+1)
            stop
          endif; endif;
        enddo !i
        do j=1,iylen
          lat(:,j)=yind(j)
          if(j<iylen) then; if(yind(j)>=yind(j+1)) then
            write(11,*)'Lat must be increasing:',j,yind(j),yind(j+1)
            stop
          endif; endif;
        enddo !j
!        lon=lon-360 !convert to our long.

!       Compute z-coord. (assuming eta=0)
!       WARNING: In zm(), 1 is bottom; ilen is surface (SCHISM convention)
        do i=1,ixlen
          do j=1,iylen
            do k=1,ilen
              zm(i,j,k)=-hnc(1+ilen-k) !lind(k)*hnc(i,j)
            enddo !k
          enddo !j
        enddo !i

!       Get rest of varid's
        status = nf90_inq_varid(sid, "temperature", tvid)
        status = nf90_inq_varid(ncids(1), "surf_el", evid)
        status = nf90_inq_varid(ncids(2), "water_u", uvid)
        status = nf90_inq_varid(ncids(2), "water_v", vvid)

!       Arrays no longer used after this: hnc,lind
        deallocate(hnc,lind)
      endif !ifile==1

!     Vertical convention follows SCHISM from now on; i.e., 1 is at bottom
!     Compute bottom indices
      if(ifile==1) then
        ilo=it0
      else
        ilo=1
      endif !ifile

      do it2=ilo,ntime
        print*, 'Time out (days)=',timeout/86400,it2

!       Read T,S,u,v,SSH
!       WARNING! Make sure the order of vertical indices is 1
!                at bottom, ilen at surface; revert if necessary!
        status = nf90_get_var(sid,svid,salt(:,:,ilen:1:-1),start=(/1,1,1,it2/),count=(/ixlen,iylen,ilen,1/))
        status = nf90_get_var(sid,tvid,temp(:,:,ilen:1:-1),start=(/1,1,1,it2/),count=(/ixlen,iylen,ilen,1/))
        status = nf90_get_var(ncids(2),uvid,uvel(:,:,ilen:1:-1),start=(/1,1,1,it2/),count=(/ixlen,iylen,ilen,1/))
        status = nf90_get_var(ncids(2),vvid,vvel(:,:,ilen:1:-1),start=(/1,1,1,it2/),count=(/ixlen,iylen,ilen,1/))
        status = nf90_get_var(ncids(1),evid,ssh,start=(/1,1,it2/),count=(/ixlen,iylen,1/))

        !Scaling etc
        salt=salt*1.e-3+20
        temp=temp*1.e-3+20
        uvel=uvel*1.e-3
        vvel=vvel*1.e-3
        ssh=ssh*1.e-3
        !Define junk value for sid; the test is salt<rjunk+0.1
        rjunk=-3.e4*1.e-3+20

!       Do sth for 1st step
        if(ifile==1.and.it2==ilo) then
!         Assume these won't change over time iteration!!
!         Find bottom index and extend
          ndrypt=0 !# of dry nodes in nc
          do i=1,ixlen
            do j=1,iylen
!             if(salt(i,j,ilen)<rjunk+0.1) then
              if(ssh(i,j)<rjunk+0.1) then !use ssh to judge
                kbp(i,j)=-1 !dry
                ndrypt=ndrypt+1
              else !wet
                !Extend near bottom
                klev0=-1 !flag
                klev=-1 !flag
                do k=1,ilen !uvel
                  if(uvel(i,j,k)>rjunk) then
                    klev(1)=k; exit
                  endif
                enddo !k
                do k=1,ilen !vvel
                  if(vvel(i,j,k)>rjunk) then
                    klev(2)=k; exit
                  endif
                enddo !k
                do k=1,ilen !temp
                  if(temp(i,j,k)>rjunk) then
                    klev(3)=k; exit
                  endif
                enddo !k
                do k=1,ilen !salt
                  if(salt(i,j,k)>rjunk) then
                    klev(4)=k; exit
                  endif
                enddo !k
                klev0=maxval(klev)

!               if(klev0<=0) then
                if(minval(klev)<=0) then
                  write(11,*)'Impossible (1):',i,j,klev!salt(i,j,ilen)
                  stop
                endif !klev0

!               Fill junk uvel, vvel with zero to eliminate HYCOM nc error
                do k=klev0,ilen
                  if (uvel(i,j,k)<rjunk) then
                    write(20,*) 'Warn! Uvel Junk in the middle:',it2,i,j,k
                    uvel(i,j,k)=0.
                  end if
                  if (vvel(i,j,k)<rjunk) then
                    write(20,*) 'Warn! Vvel Junk in the middle:',it2,i,j,k
                    vvel(i,j,k)=0.
                   end if
                end do !k
!               Fill junk salt ,temp with bottom value
                do k=klev0,ilen
                  if (temp(i,j,k)<rjunk) then
                    if(k==klev0) then
                      write(11,*)'Bottom T is junk:',it2,i,j,k,temp(i,j,k)
                      stop
                    endif
                    write(20,*) 'Warn! Temp Junk in the middle:',it2,i,j,k
                    temp(i,j,k)=temp(i,j,klev0)
                  end if
                  if (salt(i,j,k)<rjunk) then
                    if(k==klev0) then
                      write(11,*)'Bottom S is junk:',it2,i,j,k,salt(i,j,k)
                      stop
                    endif
                    write(20,*) 'Warn! Salt Junk in the middle:',it2,i,j,k
                    salt(i,j,k)=salt(i,j,klev0)
                  end if
                end do !k

                salt(i,j,1:klev0-1)=salt(i,j,klev0)
                temp(i,j,1:klev0-1)=temp(i,j,klev0)
                uvel(i,j,1:klev0-1)=uvel(i,j,klev0)
                vvel(i,j,1:klev0-1)=vvel(i,j,klev0)
                kbp(i,j)=klev0 !>0; <=ilen

                !Check
                do k=1,ilen
                  if(salt(i,j,k)<saltmin.or.salt(i,j,k)>saltmax.or. &
                    &temp(i,j,k)<tempmin.or.temp(i,j,k)>tempmax.or. &
                    &abs(uvel(i,j,k))>vmag_max.or.abs(vvel(i,j,k))>vmag_max.or. &
                    &abs(ssh(i,j))>ssh_max) then
                    write(11,*)'Fatal: no valid values:',it2,i,j,k,salt(i,j,k), &
     &temp(i,j,k),uvel(i,j,k),vvel(i,j,k),ssh(i,j)
                    stop
                  endif
                enddo !k
              endif !salt
            enddo !j
          enddo !i
!          print*, 'ndrypt=',ndrypt

!         Compute S,T etc@ invalid pts based on nearest neighbor
!         Search around neighborhood of a pt
          allocate(iparen_of_dry(2,max(1,ndrypt)))
          call cpu_time(tt0)

          icount=0
          do i=1,ixlen
            do j=1,iylen
              if(kbp(i,j)==-1) then !invalid pts
                icount=icount+1
                if(icount>ndrypt) stop 'overflow'
                !Compute max possible tier # for neighborhood
                mmax=max(i-1,ixlen-i,j-1,iylen-j)

                m=0 !tier #
                loop6: do
                  m=m+1
                  do ii=max(-m,1-i),min(m,ixlen-i)
                    i3=max(1,min(ixlen,i+ii))
                    do jj=max(-m,1-j),min(m,iylen-j)
                      j3=max(1,min(iylen,j+jj))
                      if(kbp(i3,j3)>0) then !found
                        i1=i3; j1=j3
                        exit loop6
                      endif
                    enddo !jj
                  enddo !ii

                  if(m==mmax) then
                    write(11,*)'Max. exhausted:',i,j,mmax
                    write(11,*)'kbp'
                    do ii=1,ixlen
                      do jj=1,iylen
                        write(11,*)ii,jj,kbp(ii,jj)
                      enddo !jj
                    enddo !ii
                    stop
                  endif
                end do loop6

                salt(i,j,1:ilen)=salt(i1,j1,1:ilen)
                temp(i,j,1:ilen)=temp(i1,j1,1:ilen)
                uvel(i,j,1:ilen)=uvel(i1,j1,1:ilen)
                vvel(i,j,1:ilen)=vvel(i1,j1,1:ilen)
                ssh(i,j)=ssh(i1,j1)

                !Save for other steps
                iparen_of_dry(1,icount)=i1
                iparen_of_dry(2,icount)=j1

                !Check
                do k=1,ilen
                  if(salt(i,j,k)<saltmin.or.salt(i,j,k)>saltmax.or. &
                     temp(i,j,k)<tempmin.or.temp(i,j,k)>tempmax.or. &
                     abs(uvel(i,j,k))>vmag_max.or.abs(vvel(i,j,k))>vmag_max.or. &
                     abs(ssh(i,j))>ssh_max) then
                    write(11,*)'Fatal: no valid values after searching:',it2,i,j,k,salt(i,j,k), &
     &temp(i,j,k),uvel(i,j,k),vvel(i,j,k),ssh(i,j)
                    stop
                  endif
                enddo !k

                write(12,*)icount,i,j,iparen_of_dry(1:2,icount)
              endif !kbp(i,j)==-1
            enddo !j=iylen1,iylen2
          enddo !i=ixlen1,ixlen2
          call cpu_time(tt1)
          if(icount/=ndrypt) stop 'mismatch(7)'
          write(20,*)'extending took (sec):',tt1-tt0,ndrypt
          call flush(20)

          !Save for abnormal cases later
!          salt0=salt
!          temp0=temp
!          ssh0=ssh
!          uvel0=uvel
!          vvel0=vvel

!         Test outputs
          icount=0
          do i=1,ixlen
            do j=1,iylen
              icount=icount+1
              write(95,*)icount,lon(i,j),lat(i,j),ssh(i,j)
              write(96,*)icount,lon(i,j),lat(i,j),uvel(i,j,ilen)
              write(97,*)icount,lon(i,j),lat(i,j),vvel(i,j,ilen)
              write(98,*)icount,lon(i,j),lat(i,j),salt(i,j,1) !,i,j
              write(99,*)icount,lon(i,j),lat(i,j),temp(i,j,ilen)
              write(100,*)icount,lon(i,j),lat(i,j),temp(i,j,1)
            enddo !j
          enddo !i
          print*, 'done outputting test outputs for nc'

!         Find parent elements for hgrid.ll
          call cpu_time(tt0)
          loop4: do i=1,np
            ixy(i,1:2)=0

            if(interp_mode==0) then !SG search
              do ix=1,ixlen-1
                if(xl(i)>=xind(ix).and.xl(i)<=xind(ix+1)) then
                  !Lower left corner index
                  ixy(i,1)=ix
                  xrat=(xl(i)-xind(ix))/(xind(ix+1)-xind(ix))
                  exit
                endif
              enddo !ix
              do iy=1,iylen-1
                if(yl(i)>=yind(iy).and.yl(i)<=yind(iy+1)) then
                  !Lower left corner index
                  ixy(i,2)=iy
                  yrat=(yl(i)-yind(iy))/(yind(iy+1)-yind(iy))
                  exit
                endif
              enddo !ix

              if(ixy(i,1)==0.or.ixy(i,2)==0) then
                write(11,*)'Did not find parent:',i,ixy(i,1:2)
                stop
              endif
              if(xrat<0.or.xrat>1.or.yrat<0.or.yrat>1) then
                write(11,*)'Ratio out of bound:',i,xrat,yrat
                stop
              endif

              !Bilinear shape function
              arco(1,i)=(1-xrat)*(1-yrat)
              arco(2,i)=xrat*(1-yrat)
              arco(4,i)=(1-xrat)*yrat
              arco(3,i)=xrat*yrat
            else !interp_mode=1; generic search with UG
              do ix=1,ixlen-1
                do iy=1,iylen-1
                  x1=lon(ix,iy); x2=lon(ix+1,iy); x3=lon(ix+1,iy+1); x4=lon(ix,iy+1)
                  y1=lat(ix,iy); y2=lat(ix+1,iy); y3=lat(ix+1,iy+1); y4=lat(ix,iy+1)
                  a1=abs(signa_single(xl(i),x1,x2,yl(i),y1,y2))
                  a2=abs(signa_single(xl(i),x2,x3,yl(i),y2,y3))
                  a3=abs(signa_single(xl(i),x3,x4,yl(i),y3,y4))
                  a4=abs(signa_single(xl(i),x4,x1,yl(i),y4,y1))
                  b1=abs(signa_single(x1,x2,x3,y1,y2,y3))
                  b2=abs(signa_single(x1,x3,x4,y1,y3,y4))
                  rat=abs(a1+a2+a3+a4-b1-b2)/(b1+b2)
                  if(rat<small1) then
                    ixy(i,1)=ix; ixy(i,2)=iy
!                 Find a triangle
                    in=0 !flag
                    do l=1,2
                      ap=abs(signa_single(xl(i),x1,x3,yl(i),y1,y3))
                      if(l==1) then !nodes 1,2,3
                        bb=abs(signa_single(x1,x2,x3,y1,y2,y3))
                        wild(l)=abs(a1+a2+ap-bb)/bb
                        if(wild(l)<small1*5) then
                          in=1
                          arco(1,i)=max(0.,min(1.,a2/bb))
                          arco(2,i)=max(0.,min(1.,ap/bb))
                          arco(3,i)=max(0.,min(1.,1-arco(1,i)-arco(2,i)))
                          arco(4,i)=0.
                          exit
                        endif
                      else !nodes 1,3,4
                        bb=abs(signa_single(x1,x3,x4,y1,y3,y4))
                        wild(l)=abs(a3+a4+ap-bb)/bb
                        if(wild(l)<small1*5) then
                          in=2
                          arco(1,i)=max(0.,min(1.,a3/bb))
                          arco(3,i)=max(0.,min(1.,a4/bb))
                          arco(4,i)=max(0.,min(1.,1-arco(1,i)-arco(3,i)))
                          arco(2,i)=0.
                          exit
                        endif
                      endif
                    enddo !l=1,2
                    if(in==0) then
                      write(11,*)'Cannot find a triangle:',(wild(l),l=1,2)
                      stop
                    endif
                    !ixy(i,3)=in
                    cycle loop4
                  endif !rat<small1
                enddo !iy=iylen1,iylen2-1
              enddo !ix=ixlen1,ixlen2-1
            endif !interp_mode
          end do loop4 !i=1,np

          call cpu_time(tt1)
          write(20,*)'weights took (sec):',tt1-tt0
          call flush(20)

        else !skip to extend
          do i=1,ixlen
            do j=1,iylen
              if(kbp(i,j)>0) then !valid
!               Check ssh consistency by kbp
!               If not consistent, seek nearby points to replace
!               Force ssh = 0 if none are found
                if (ssh(i,j)<rjunk+0.1) then
                  do ii=1,2
                    do jj=1,2
                      if (ssh(i+ii,j+jj)>rjunk) then
                        ssh(i,j)=ssh(i+ii,j+jj);exit
                      end if
                    end do
                  end do !ii
                  if (ssh(i,j)<rjunk+0.1) then
                    write(20,*) 'Warning! SSH Junk, fill with 0: ',it2,i,j
                    ssh(i,j)=0. !fill with 0 if no finding
                  end if
                end if

                !Extend bottom (kbp changes over time)
                klev0=-1 !flag
                klev=-1 !flag
                do k=1,ilen !uvel
                  if(uvel(i,j,k)>rjunk) then
                    klev(1)=k; exit
                  endif
                enddo !k
                do k=1,ilen !vvel
                  if(vvel(i,j,k)>rjunk) then
                    klev(2)=k; exit
                  endif
                enddo !k
                do k=1,ilen !temp
                  if(temp(i,j,k)>rjunk) then
                    klev(3)=k; exit
                  endif
                enddo !k
                do k=1,ilen !salt
                  if(salt(i,j,k)>rjunk) then
                    klev(4)=k; exit
                  endif
                enddo !k
                klev0=maxval(klev)

!               if(klev0<=0) then
                if(minval(klev)<=0) then
                  write(11,*)'Impossible (4):',i,j,klev !salt(i,j,ilen)
                  stop
                endif !klev0

!               Fill junk uvel, vvel with zero to easy eliminate HYCOM nc error
                do k=klev0,ilen
                  if (uvel(i,j,k)<rjunk) then
                    write(20,*) 'Warn! Uvel Junk in the middle:',it2,i,j,k
                    uvel(i,j,k)=0.
                  end if
                  if (vvel(i,j,k)<rjunk) then
                    write(20,*) 'Warn! Vvel Junk in the middle:',it2,i,j,k
                    vvel(i,j,k)=0.
                  end if
                end do
!               Fill junk salt ,temp with bottom value
                do k=klev0,ilen
                  if (temp(i,j,k)<rjunk) then
                    if(k==klev0) then
                      write(11,*)'Bottom T is junk(2):',it2,i,j,k,temp(i,j,k)
                      stop
                    endif
                    write(20,*) 'Warn! Temp Junk in the middle:',it2,i,j,k
                    temp(i,j,k)=temp(i,j,klev0)
                  end if
                  if (salt(i,j,k)<rjunk) then
                    if(k==klev0) then
                      write(11,*)'Bottom S is junk(2):',it2,i,j,k,salt(i,j,k)
                      stop
                    endif

                    write(20,*) 'Warn! Salt Junk in the middle:',it2,i,j,k
                    salt(i,j,k)=salt(i,j,klev0)
                  end if
                end do

                salt(i,j,1:klev0-1)=salt(i,j,klev0)
                temp(i,j,1:klev0-1)=temp(i,j,klev0)
                uvel(i,j,1:klev0-1)=uvel(i,j,klev0)
                vvel(i,j,1:klev0-1)=vvel(i,j,klev0)

                !Check
                do k=1,ilen
                  if(salt(i,j,k)<saltmin.or.salt(i,j,k)>saltmax.or. &
                    &temp(i,j,k)<tempmin.or.temp(i,j,k)>tempmax.or. &
                    &abs(uvel(i,j,k))>vmag_max.or.abs(vvel(i,j,k))>vmag_max.or. &
                    &abs(ssh(i,j))>ssh_max) then
                    write(11,*)'no valid values after searching(1):',it2,i,j,k,salt(i,j,:), &
     &temp(i,j,:),uvel(i,j,:),vvel(i,j,:),'; SSH:',ssh(i,j)
!'                   salt(i,j,k)=salt0(i,j,k)
!                    temp(i,j,k)=temp0(i,j,k)
!                    uvel(i,j,k)=uvel0(i,j,k)
!                    vvel(i,j,k)=vvel0(i,j,k)
!                    ssh(i,j)=ssh0(i,j)
                    stop
                  endif
                enddo !k
              endif
            enddo !j
          enddo !i

          icount=0
          do i=1,ixlen
            do j=1,iylen
              if(kbp(i,j)==-1) then !dry pt
                icount=icount+1
                !Use extended parents
                i1=iparen_of_dry(1,icount); j1=iparen_of_dry(2,icount)
                salt(i,j,1:ilen)=salt(i1,j1,1:ilen)
                temp(i,j,1:ilen)=temp(i1,j1,1:ilen)
                uvel(i,j,1:ilen)=uvel(i1,j1,1:ilen)
                vvel(i,j,1:ilen)=vvel(i1,j1,1:ilen)
                ssh(i,j)=ssh(i1,j1)

                !Check
                do k=1,ilen
                  if(salt(i,j,k)<saltmin.or.salt(i,j,k)>saltmax.or. &
                    &temp(i,j,k)<tempmin.or.temp(i,j,k)>tempmax.or. &
                    &abs(uvel(i,j,k))>vmag_max.or.abs(vvel(i,j,k))>vmag_max.or. &
                    &abs(ssh(i,j))>ssh_max) then
                    write(11,*)'Warning: no valid values after searching(2):',it2,i,j,k,salt(i,j,k), &
     &temp(i,j,k),uvel(i,j,k),vvel(i,j,k),ssh(i,j),i1,j1,'; ',salt(i1,j1,:),temp(i1,j1,:),uvel(i1,j1,:)
!'
                    stop
                  endif
                enddo !k
              endif !kbp
            enddo !j
          enddo !i
          if(icount/=ndrypt) stop 'mismatch(8)'

          !Save for abnormal cases later
!          salt0=salt
!          temp0=temp
!          ssh0=ssh
!          uvel0=uvel
!          vvel0=vvel

          write(20,*)'done prep for step:',it2
          call flush(20)
        endif !ifile==1.and.it2==

!       Do interpolation: all at 1st  step, bnd only for the rest
        if(ifile==1.and.it2==ilo) then
          iup=np
        else
          iup=nond0
        endif

        tempout=-99; saltout=-99
        do ii=1,iup
          if(ifile==1.and.it2==ilo) then
            i=ii
          else
            i=iond2(ii)
          endif

          if(ixy(i,1)==0.or.ixy(i,2)==0) then
            write(20,*)'Cannot find a parent element:',i
            tempout(:,i)=tem_outside
            saltout(:,i)=sal_outside
            uout(:,i)=0
            vout(:,i)=0
            eout(i)=0
          else !found parent
            ix=ixy(i,1); iy=ixy(i,2) !; in=ixy(i,3)
            !Find vertical level
            do k=1,nvrt
              if(kbp(ix,iy)==-1) then
                lev=ilen-1; vrat=1
              else if(z(k,i)<=zm(ix,iy,kbp(ix,iy))) then
                !lev=kbp(ix,iy); vrat=0
                lev=1; vrat=0
              else if(z(k,i)>=zm(ix,iy,ilen)) then !above f.s.
                lev=ilen-1; vrat=1
              else
                lev=-99 !flag
                do kk=1,ilen-1
                  if(z(k,i)>=zm(ix,iy,kk).and.z(k,i)<=zm(ix,iy,kk+1)) then
                    lev=kk
                    vrat=(zm(ix,iy,kk)-z(k,i))/(zm(ix,iy,kk)-zm(ix,iy,kk+1))
                    exit
                  endif
                enddo !kk
                if(lev==-99) then
                  write(11,*)'Cannot find a level:',i,k,z(k,i),(zm(ix,iy,l),l=1,kbp(ix,iy))
                  stop
                endif
              endif

!              write(18,*)i,k,ix,iy,lev,vrat,kbp(ix,iy)
              if(lev>=ilen) then
                write(11,*)'lev:',lev,ix,iy,k,i,ilen,vrat,kbp(ix,iy),z(k,i),zm(ix,iy,1:ilen)
                stop
              endif
              wild2(1,1)=temp(ix,iy,lev)*(1-vrat)+temp(ix,iy,lev+1)*vrat
              wild2(1,2)=salt(ix,iy,lev)*(1-vrat)+salt(ix,iy,lev+1)*vrat
              wild2(2,1)=temp(ix+1,iy,lev)*(1-vrat)+temp(ix+1,iy,lev+1)*vrat
              wild2(2,2)=salt(ix+1,iy,lev)*(1-vrat)+salt(ix+1,iy,lev+1)*vrat
              wild2(3,1)=temp(ix+1,iy+1,lev)*(1-vrat)+temp(ix+1,iy+1,lev+1)*vrat
              wild2(3,2)=salt(ix+1,iy+1,lev)*(1-vrat)+salt(ix+1,iy+1,lev+1)*vrat
              wild2(4,1)=temp(ix,iy+1,lev)*(1-vrat)+temp(ix,iy+1,lev+1)*vrat
              wild2(4,2)=salt(ix,iy+1,lev)*(1-vrat)+salt(ix,iy+1,lev+1)*vrat

              wild2(5,1)=uvel(ix,iy,lev)*(1-vrat)+uvel(ix,iy,lev+1)*vrat
              wild2(5,2)=vvel(ix,iy,lev)*(1-vrat)+vvel(ix,iy,lev+1)*vrat
              wild2(6,1)=uvel(ix+1,iy,lev)*(1-vrat)+uvel(ix+1,iy,lev+1)*vrat
              wild2(6,2)=vvel(ix+1,iy,lev)*(1-vrat)+vvel(ix+1,iy,lev+1)*vrat
              wild2(7,1)=uvel(ix+1,iy+1,lev)*(1-vrat)+uvel(ix+1,iy+1,lev+1)*vrat
              wild2(7,2)=vvel(ix+1,iy+1,lev)*(1-vrat)+vvel(ix+1,iy+1,lev+1)*vrat
              wild2(8,1)=uvel(ix,iy+1,lev)*(1-vrat)+uvel(ix,iy+1,lev+1)*vrat
              wild2(8,2)=vvel(ix,iy+1,lev)*(1-vrat)+vvel(ix,iy+1,lev+1)*vrat

              tempout(k,i)=dot_product(wild2(1:4,1),arco(1:4,i))
              saltout(k,i)=dot_product(wild2(1:4,2),arco(1:4,i))
              uout(k,i)=dot_product(wild2(5:8,1),arco(1:4,i))
              vout(k,i)=dot_product(wild2(5:8,2),arco(1:4,i))
              eout(i)=ssh(ix,iy)*arco(1,i)+ssh(ix+1,iy)*arco(2,i)+ssh(ix+1,iy+1)*arco(3,i)+ssh(ix,iy+1)*arco(4,i)

!              if(in==1) then
!                tempout(k,i)=wild2(1,1)*arco(1,i)+wild2(2,1)*arco(2,i)+wild2(3,1)*arco(3,i)
!                saltout(k,i)=wild2(1,2)*arco(1,i)+wild2(2,2)*arco(2,i)+wild2(3,2)*arco(3,i)
!                uout(k,i)=wild2(5,1)*arco(1,i)+wild2(6,1)*arco(2,i)+wild2(7,1)*arco(3,i)
!                vout(k,i)=wild2(5,2)*arco(1,i)+wild2(6,2)*arco(2,i)+wild2(7,2)*arco(3,i)
!                eout(i)=ssh(ix,iy)*arco(1,i)+ssh(ix+1,iy)*arco(2,i)+ssh(ix+1,iy+1)*arco(3,i)
!              else
!                tempout(k,i)=wild2(1,1)*arco(1,i)+wild2(3,1)*arco(2,i)+wild2(4,1)*arco(3,i)
!                saltout(k,i)=wild2(1,2)*arco(1,i)+wild2(3,2)*arco(2,i)+wild2(4,2)*arco(3,i)
!                uout(k,i)=wild2(5,1)*arco(1,i)+wild2(7,1)*arco(2,i)+wild2(8,1)*arco(3,i)
!                vout(k,i)=wild2(5,2)*arco(1,i)+wild2(7,2)*arco(2,i)+wild2(8,2)*arco(3,i)
!                eout(i)=ssh(ix,iy)*arco(1,i)+ssh(ix+1,iy+1)*arco(2,i)+ssh(ix,iy+1)*arco(3,i)
!              endif

              !Check
              if(tempout(k,i)<tempmin.or.tempout(k,i)>tempmax.or. &
                saltout(k,i)<saltmin.or.saltout(k,i)>saltmax.or. &
                abs(uout(k,i))>vmag_max.or.abs(vout(k,i))>vmag_max.or.abs(eout(i))>ssh_max) then
                write(11,*)'Interpolated values invalid:',i,k,tempout(k,i),saltout(k,i),uout(k,i), &
     &vout(k,i),eout(i),temp(ix,iy,lev)
                stop
              endif

!             Enforce lower bound for temp. for eqstate
              tempout(k,i)=max(0.,tempout(k,i))
              saltout(k,i)=min(40.,saltout(k,i))

!             Enforce lower bound for salt (this is the only occurence in the code)
!             if(z(k,i)<=-ht) saltout(k,i)=max(saltout(k,i),smin)
            enddo !k=1,nvrt

            !Estuary pts
            if(iest(i)==1) then
              tempout(:,i)=tem_es
              saltout(:,i)=sal_es
            endif
          endif !ixy(i,1)==0.or.
        enddo !ii

!       hotstart.nc
        if(ifile==1.and.it2==ilo) then
          write(20,*)'outputting hot...'
          call flush(20)

          do i=1,ns
            n1=isidenode(1,i)
            n2=isidenode(2,i)
            do k=1,nvrt
!              tsd(i,k)=(tempout(n1,k)+tempout(n2,k))/2
!              ssd(i,k)=(saltout(n1,k)+saltout(n2,k))/2
              if(iuv==0) then
                su2(k,i)=0; sv2(k,i)=0
              else
                su2(k,i)=(uout(k,n1)+uout(k,n2))/2
                sv2(k,i)=(vout(k,n1)+vout(k,n2))/2
              endif !iuv
            enddo !k
!           write(88,*)i,xcj(i),ycj(i),ssd(i,1),ssd(i,nvrt)
          enddo !i

          do i=1,ne
            do k=2,nvrt
              tsel(1,k,i)=(sum(tempout(k,elnode(1:i34(i),i)))+sum(tempout(k-1,elnode(1:i34(i),i))))/2/i34(i)
              tsel(2,k,i)=(sum(saltout(k,elnode(1:i34(i),i)))+sum(saltout(k-1,elnode(1:i34(i),i))))/2/i34(i)
            enddo !k
            tsel(1,1,i)=tsel(1,2,i) !mainly for hotstart format
            tsel(2,1,i)=tsel(2,2,i)
          enddo !i

          if(iuv==0) then
            eout_tmp=0
          else
            eout_tmp=eout
          endif

!         Debug
          do i=1,np
            write(26,*)i,xl(i),yl(i),saltout(nvrt,i)
            write(30,*)i,xl(i),yl(i),tempout(nvrt,i)
            write(21,*)i,xl(i),yl(i),tempout(1,i)
            write(24,*)xl(i),yl(i),uout(1,i),vout(1,i)
            write(27,*)xl(i),yl(i),uout(nvrt,i),vout(nvrt,i)
            write(25,*)i,xl(i),yl(i),eout(i)
            write(29,*)'T profile at node ',i,dp(i)
            do k=1,nvrt
              write(29,*)k,z(k,i),tempout(k,i)
            enddo !k
          enddo !i
          do i=1,ne
            write(22,*)i,tsel(1,nvrt,i) !T
            write(23,*)i,tsel(1,1,i)
          enddo !i

!         Output hotstart
!          open(36,file='hotstart.in',form='unformatted',status='replace')
!          write(36) 0.d0,0,1
!          do i=1,ne
!            write(36) i,0,(0.d0,dble(tsel(1:2,j,i)),j=1,nvrt)
!          enddo !i
!          do i=1,ns
!            write(36) i,0,(dble(su2(j,i)),dble(sv2(j,i)),dble(tsd(i,j)),dble(ssd(i,j)),j=1,nvrt)
!          enddo !i
!          do i=1,np
!            write(36) i,dble(eout_tmp(i)),0,(dble(tempout(j,i)),dble(saltout(j,i)), &
!                      dble(tempout(j,i)),dble(saltout(j,i)),0.d0,0.d0, &
!                      0.d0,0.d0,0.d0,0.d0,0.d0,j=1,nvrt)
!          enddo !i
!          close(36)

          iret=nf90_create('hotstart.nc',OR(NF90_NETCDF4,NF90_CLOBBER),ncids(4))
          iret=nf90_def_dim(ncids(4),'node',np,node_dim)
          iret=nf90_def_dim(ncids(4),'elem',ne,nele_dim)
          iret=nf90_def_dim(ncids(4),'side',ns,nedge_dim)
          iret=nf90_def_dim(ncids(4),'nVert',nvrt,nv_dim)
          iret=nf90_def_dim(ncids(4),'ntracers',2,ntr_dim)
          iret=nf90_def_dim(ncids(4),'one',1,one_dim)
          var1d_dims(1)=one_dim
          iret=nf90_def_var(ncids(4),'time',NF90_DOUBLE,var1d_dims,ivarid(1))
          iret=nf90_def_var(ncids(4),'iths',NF90_INT,var1d_dims,ivarid(2))
          iret=nf90_def_var(ncids(4),'ifile',NF90_INT,var1d_dims,ivarid(3))
          var1d_dims(1)=nele_dim
          iret=nf90_def_var(ncids(4),'idry_e',NF90_INT,var1d_dims,ivarid(4))
          var1d_dims(1)=nedge_dim
          iret=nf90_def_var(ncids(4),'idry_s',NF90_INT,var1d_dims,ivarid(5))
          var1d_dims(1)=node_dim
          iret=nf90_def_var(ncids(4),'idry',NF90_INT,var1d_dims,ivarid(6))
          iret=nf90_def_var(ncids(4),'eta2',NF90_DOUBLE,var1d_dims,ivarid(7))
          var2d_dims(1)=nv_dim; var2d_dims(2)=nele_dim
          iret=nf90_def_var(ncids(4),'we',NF90_DOUBLE,var2d_dims,ivarid(8))
          var3d_dims(1)=ntr_dim; var3d_dims(2)=nv_dim; var3d_dims(3)=nele_dim
          iret=nf90_def_var(ncids(4),'tr_el',NF90_DOUBLE,var3d_dims,ivarid(9))
          var3d_dims(1)=ntr_dim; var3d_dims(2)=nv_dim; var3d_dims(3)=node_dim
          iret=nf90_def_var(ncids(4),'tr_nd',NF90_DOUBLE,var3d_dims,ivarid(10))
          iret=nf90_def_var(ncids(4),'tr_nd0',NF90_DOUBLE,var3d_dims,ivarid(11))
          var2d_dims(1)=nv_dim; var2d_dims(2)=nedge_dim
          iret=nf90_def_var(ncids(4),'su2',NF90_DOUBLE,var2d_dims,ivarid(12))
          iret=nf90_def_var(ncids(4),'sv2',NF90_DOUBLE,var2d_dims,ivarid(13))
          var2d_dims(1)=nv_dim; var2d_dims(2)=node_dim
          iret=nf90_def_var(ncids(4),'q2',NF90_DOUBLE,var2d_dims,ivarid(14))
          iret=nf90_def_var(ncids(4),'xl',NF90_DOUBLE,var2d_dims,ivarid(15))
          iret=nf90_def_var(ncids(4),'dfv',NF90_DOUBLE,var2d_dims,ivarid(16))
          iret=nf90_def_var(ncids(4),'dfh',NF90_DOUBLE,var2d_dims,ivarid(17))
          iret=nf90_def_var(ncids(4),'dfq1',NF90_DOUBLE,var2d_dims,ivarid(18))
          iret=nf90_def_var(ncids(4),'dfq2',NF90_DOUBLE,var2d_dims,ivarid(19))
          iret=nf90_enddef(ncids(4))

          idry_s=0; zeros=0
          iret=nf90_put_var(ncids(4),ivarid(1),dble(0.))
          iret=nf90_put_var(ncids(4),ivarid(2),0)
          iret=nf90_put_var(ncids(4),ivarid(3),1)
          iret=nf90_put_var(ncids(4),ivarid(4),idry_s(1:ne),(/1/),(/ne/))
          iret=nf90_put_var(ncids(4),ivarid(5),idry_s(1:ns),(/1/),(/ns/))
          iret=nf90_put_var(ncids(4),ivarid(6),idry_s(1:np),(/1/),(/np/))
          iret=nf90_put_var(ncids(4),ivarid(7),dble(eout_tmp(1:np)),(/1/),(/np/))
          iret=nf90_put_var(ncids(4),ivarid(8),dble(zeros(1:nvrt,1:ne)),(/1,1/),(/nvrt,ne/))
          iret=nf90_put_var(ncids(4),ivarid(9),dble(tsel(1:2,1:nvrt,1:ne)))
          iret=nf90_put_var(ncids(4),ivarid(10),dble(tempout(1:nvrt,1:np)),(/1,1,1/),(/1,nvrt,np/))
          iret=nf90_put_var(ncids(4),ivarid(10),dble(saltout(1:nvrt,1:np)),(/2,1,1/),(/1,nvrt,np/))
          iret=nf90_put_var(ncids(4),ivarid(11),dble(tempout(1:nvrt,1:np)),(/1,1,1/),(/1,nvrt,np/))
          iret=nf90_put_var(ncids(4),ivarid(11),dble(saltout(1:nvrt,1:np)),(/2,1,1/),(/1,nvrt,np/))
          iret=nf90_put_var(ncids(4),ivarid(12),dble(su2(1:nvrt,1:ns)))
          iret=nf90_put_var(ncids(4),ivarid(13),dble(sv2(1:nvrt,1:ns)))
          iret=nf90_put_var(ncids(4),ivarid(14),dble(zeros(1:nvrt,1:np)))
          iret=nf90_put_var(ncids(4),ivarid(15),dble(zeros(1:nvrt,1:np)))
          iret=nf90_put_var(ncids(4),ivarid(16),dble(zeros(1:nvrt,1:np)))
          iret=nf90_put_var(ncids(4),ivarid(17),dble(zeros(1:nvrt,1:np)))
          iret=nf90_put_var(ncids(4),ivarid(18),dble(zeros(1:nvrt,1:np)))
          iret=nf90_put_var(ncids(4),ivarid(19),dble(zeros(1:nvrt,1:np)))

          iret=nf90_close(ncids(4))

!          stop

        endif !ifile; hotstart

!       *[23D].th
!        write(54,rec=irecout)timeout,eout(iond2(1:nond0))
!        write(55,rec=irecout)timeout,((uout(k,iond2(j)),vout(k,iond2(j)),k=1,nvrt),j=1,nond0)
!        write(56,rec=irecout)timeout,((tempout(k,iond2(j)),k=1,nvrt),j=1,nond0)
!        write(57,rec=irecout)timeout,((saltout(k,iond2(j)),k=1,nvrt),j=1,nond0)

        aa1(1)=timeout
        iret=nf90_put_var(ncids(5),itime_id(1),aa1,(/irecout/),(/1/))
        iret=nf90_put_var(ncids(6),itime_id(2),aa1,(/irecout/),(/1/))
        iret=nf90_put_var(ncids(7),itime_id(3),aa1,(/irecout/),(/1/))
        iret=nf90_put_var(ncids(8),itime_id(4),aa1,(/irecout/),(/1/))

        iret=nf90_put_var(ncids(5),ivarid(51),eout(iond2(1:nond0)),(/1,1,1,irecout/),(/1,1,nond0,1/))
        iret=nf90_put_var(ncids(6),ivarid(52),uout(1:nvrt,iond2(1:nond0)), &
     &(/1,1,1,irecout/),(/1,nvrt,nond0,1/))
        iret=nf90_put_var(ncids(6),ivarid(52),vout(1:nvrt,iond2(1:nond0)), &
     &(/2,1,1,irecout/),(/1,nvrt,nond0,1/))
        iret=nf90_put_var(ncids(7),ivarid(53),tempout(1:nvrt,iond2(1:nond0)), &
     &(/1,1,1,irecout/),(/1,nvrt,nond0,1/))
        iret=nf90_put_var(ncids(8),ivarid(54),saltout(1:nvrt,iond2(1:nond0)), &
     &(/1,1,1,irecout/),(/1,nvrt,nond0,1/))

        irecout=irecout+1
        timeout=timeout+dtout !sec

!        write(20,*)'done time:',timeout/86400
!        call flush(20)

        if(timeout/86400>nndays) stop 'finished'

      enddo !it2=ilo,ntime

      status = nf90_close(sid)
      status = nf90_close(ncids(1))
      status = nf90_close(ncids(2))
!end11
      print*, 'done reading nc for file ',ifile
!--------------------------------------------------------------------
      enddo !ifile=1

      iret=nf90_close(ncids(5))
      iret=nf90_close(ncids(6))
      iret=nf90_close(ncids(7))
      iret=nf90_close(ncids(8))

!      deallocate(lat,lon,zm,h,kbp,ihope,xind,yind,lind,salt,temp)

!      print*, 'Finished'
!     End of main
!     Subroutines
      contains
!     Internal subroutine - checks error status after each netcdf,
!     prints out text message each time an error code is returned.
      subroutine check(status)
      integer, intent ( in) :: status

      if(status /= nf90_noerr) then
        print *, trim(nf90_strerror(status))
        print *, 'failed to open nc files'
        stop
      end if
      end subroutine check

      end program gen_hot