    module sizes_mod

         INTEGER,  PARAMETER :: sp = SELECTED_REAL_KIND(6, 37)
         INTEGER,  PARAMETER :: dp = SELECTED_REAL_KIND(12, 307)
         INTEGER,  PARAMETER :: wp = dp

   end module sizes_mod

    module cuda_mod
         use cudafor
         use sizes_mod
         IMPLICIT NONE

     contains

        ! Assumes padded allocations
        SUBROUTINE momentum_acc(un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, &
                                                   hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, &
                                                   gphiu, gphiv, e12u, e12v, pt, ua, va ,&
                                                   ssha, e12t, &
                                                   visc, omega, d2r, g, rdt, cbfr, jpi, jpj)

          REAL(wp), intent(in), device, dimension(-31:jpi,1:jpj) :: un, hu, gphiu, e1u, e2u, sshn_u, ssha_u, e12u
          REAL(wp), intent(in), device, dimension(1:jpi,0:jpj)   :: vn, hv, gphiv, e1v, e2v, sshn_v, ssha_v, e12v
          REAL(wp), intent(in), device, dimension(1:jpi,1:jpj)   :: sshn, ht, e1t, e2t, e12t
          REAL(wp), intent(out), device, dimension(1:jpi,1:jpj)  :: ssha

          INTEGER, intent(in), device, dimension(0:jpi+1+30,0:jpj+1) :: pt
          INTEGER,  value, intent(in) :: jpi, jpj
          REAL(wp), value, intent(in) :: visc, omega, d2r, g, rdt, cbfr

          REAL(wp), intent(out), device, dimension(-31:jpi,1:jpj) :: ua
          REAL(wp), intent(out), device, dimension(1:jpi,0:jpj) :: va

          REAL(wp) :: rtmp1, rtmp2, rtmp3, rtmp4

          REAL(wp) :: u_e, u_w
          REAL(wp) :: v_s, v_n
          REAL(wp) :: v_sc, v_nc, u_ec, u_wc
          REAL(wp) :: uu_e, uu_w, uu_s, uu_n
          REAL(wp) :: vv_e, vv_w, vv_s, vv_n
          REAL(wp) :: depe, depw, deps, depn
          REAL(wp) :: dudx_e, dudy_n, dvdx_e, dvdy_n
          REAL(wp) :: dudx_w, dudy_s, dvdx_w, dvdy_s

          REAL(wp) :: adv, vis, hpg, cor
          INTEGER  :: ji, jj, js, jii, je                          !temporary loop index

          ! Reads: un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, gphiu, gphiv, e12u, e12v (20)
          ! Reads (int): pt (1)
          ! Writes: ua, va (2)
          ! = 180 bytes
          ! For 1026x1026 = 181 MB.

          ! u equation
          !$acc kernels present(un, vn, hu, ht, sshn_u, sshn, e1t, e2t, e2u)
          ! acc loop shortloop
          DO jj = 1, jpj
          ! acc loop shortloop
          DO ji = 1, jpi
! kernel u adv
             IF (ji <= jpi-1) THEN ! .AND. &
               ! (pt(ji,jj) + pt(ji+1,jj) > 0) .AND. &                 !jump over non-computatinal domain
               ! (pt(ji,jj) > 0 .AND. pt(ji+1,jj) > 0))  THEN                    !jump over boundary u

             ! IF(pt(ji,jj) + pt(ji+1,jj) <= 0)  CYCLE                    !jump over non-computatinal domain
             ! IF(pt(ji,jj) <= 0 .OR. pt(ji+1,jj) <= 0)  CYCLE                    !jump over boundary u

             u_e  = 0.5 * (un(ji,jj) + un(ji+1,jj)) * e2t(ji+1,jj)      !add length scale.
             depe = ht(ji+1,jj) + sshn(ji+1,jj)

             u_w  = 0.5 * (un(ji,jj) + un(ji-1,jj)) * e2t(ji,jj)        !add length scale
             depw = ht(ji,jj) + sshn(ji,jj)

             v_sc = 0.5_wp * (vn(ji,jj-1) + vn(ji+1,jj-1))
             v_s  = 0.5_wp * v_sc * (e1v(ji,jj-1) + e1v(ji+1,jj-1))
             deps = 0.5_wp * (hv(ji,jj-1) + sshn_v(ji,jj-1) + hv(ji+1,jj-1) + sshn_v(ji+1,jj-1))

             v_nc = 0.5_wp * (vn(ji,jj) + vn(ji+1,jj))
             v_n  = 0.5_wp * v_nc * (e1v(ji,jj) + e1v(ji+1,jj))
             depn = 0.5_wp * (hv(ji,jj) + sshn_v(ji,jj) + hv(ji+1,jj) + sshn_v(ji+1,jj))

            ! -advection (currently first order upwind)
            uu_w = (0.5_wp - SIGN(0.5_wp, u_w)) * un(ji,jj)              + &
                 & (0.5_wp + SIGN(0.5_wp, u_w)) * un(ji-1,jj)
            uu_e = (0.5_wp + SIGN(0.5_wp, u_e)) * un(ji,jj)              + &
                 & (0.5_wp - SIGN(0.5_wp, u_e)) * un(ji+1,jj)

            IF(pt(ji,jj-1) <=0 .OR. pt(ji+1,jj-1) <= 0) THEN
               uu_s = (0.5_wp - SIGN(0.5_wp, v_s)) * un(ji,jj)
            ELSE
               uu_s = (0.5_wp - SIGN(0.5_wp, v_s)) * un(ji,jj)              + &
                    & (0.5_wp + SIGN(0.5_wp, v_s)) * un(ji,jj-1)
            END If

            IF(pt(ji,jj+1) <=0 .OR. pt(ji+1,jj+1) <= 0) THEN
               uu_n = (0.5_wp + SIGN(0.5_wp, v_n)) * un(ji,jj)
            ELSE
               uu_n = (0.5_wp + SIGN(0.5_wp, v_n)) * un(ji,jj)              + &
                    & (0.5_wp - SIGN(0.5_wp, v_n)) * un(ji,jj+1)
            END IF

            adv = uu_w * u_w * depw - uu_e * u_e * depe + uu_s * v_s * deps - uu_n * v_n * depn
!end kernel u adv

            ! -viscosity

!kernel  u vis
            dudx_e = (un(ji+1,jj) - un(ji,  jj)) / e1t(ji+1,jj) * (ht(ji+1,jj) + sshn(ji+1,jj))
            dudx_w = (un(ji,  jj) - un(ji-1,jj)) / e1t(ji,  jj) * (ht(ji,  jj) + sshn(ji,  jj))
            IF(pt(ji,jj-1) <=0 .OR. pt(ji+1,jj-1) <= 0) THEN
              dudy_s = 0.0_wp !slip boundary
            ELSE
              dudy_s = (un(ji,jj) - un(ji,jj-1)) / (e2u(ji,jj) + e2u(ji,jj-1)) * &
                     & (hu(ji,jj) + sshn_u(ji,jj) + hu(ji,jj-1) + sshn_u(ji,jj-1))
            END IF

            IF(pt(ji,jj+1) <= 0 .OR. pt(ji+1,jj+1) <= 0) THEN
              dudy_n = 0.0_wp ! slip boundary
            ELSE
              dudy_n = (un(ji,jj+1) - un(ji,jj)) / (e2u(ji,jj) + e2u(ji,jj+1)) * &
                     & (hu(ji,jj) + sshn_u(ji,jj) + hu(ji,jj+1) + sshn_u(ji,jj+1))
            END If

            vis = (dudx_e - dudx_w ) * e2u(ji,jj)  + &
                & (dudy_n - dudy_s ) * e1u(ji,jj) * 0.5_wp
            vis = visc * vis   !visc will be an array visc(1:jpijglou)
                               !for variable viscosity, such as turbulent viscosity
!End  kernel u vis

            ! -Coriolis' force (can be implemented implicitly)
!kernel cor
            cor = 0.5_wp * (2._wp * omega * SIN(gphiu(ji,jj) * d2r) * (v_sc + v_nc)) * &
                & e12u(ji,jj) * (hu(ji,jj) + sshn_u(ji,jj))
!end kernel cor

            ! -pressure gradient
!start kernel hpg
            hpg = -g * (hu(ji,jj) + sshn_u(ji,jj)) * e2u(ji,jj) * (sshn(ji+1,jj) - sshn(ji,jj))
!end kernel hpg
            ! -linear bottom friction (implemented implicitly.
!kernel ua calculation
            ua(ji,jj) = (un(ji,jj) * (hu(ji,jj) + sshn_u(ji,jj)) + rdt * (adv + vis + cor + hpg) / e12u(ji,jj)) / &
                   & (hu(ji,jj) + ssha_u(ji,jj)) / (1.0_wp + cbfr * rdt)
!end kernel ua
            END IF
         END DO
       END DO

       ! v equation
       ! acc loop shortloop
       DO jj = 1, jpj
          ! acc loop shortloop
          DO ji = 1, jpi

             IF (jj <= jpj-1) THEN ! .AND. &
               ! pt(ji,jj) + pt(ji+1,jj) >= 0 .AND. &                         !jump over non-computatinal domain
               ! (pt(ji,jj) > 0 .AND. pt(ji,jj+1) > 0))  THEN                !jump over v boundary cells

             ! IF(pt(ji,jj) + pt(ji+1,jj) <= 0)  CYCLE                    !jump over non-computatinal domain
             ! IF(pt(ji,jj) <= 0 .OR. pt(ji,jj+1) <= 0)  CYCLE                !jump over v boundary cells

! kernel v adv
             v_n  = 0.5 * (vn(ji,jj) + vn(ji,jj+1)) * e1t(ji,jj+1)  !add length scale.
             depn = ht(ji,jj+1) + sshn(ji,jj+1)

             v_s  = 0.5 * (vn(ji,jj) + vn(ji,jj-1)) * e1t(ji,jj)    !add length scale
             deps = ht(ji,jj) + sshn(ji,jj)

             u_wc = 0.5_wp * (un(ji-1,jj) + un(ji-1,jj+1))
             u_w  = 0.5_wp * u_wc * (e2u(ji-1,jj) + e2u(ji-1,jj+1))
             depw = 0.50_wp * (hu(ji-1,jj) + sshn_u(ji-1,jj) + hu(ji-1,jj+1) + sshn_u(ji-1,jj+1))

             u_ec = 0.5_wp * (un(ji,jj) + un(ji,jj+1))
             u_e  = 0.5_wp * u_ec * (e2u(ji,jj) + e2u(ji,jj+1))
             depe = 0.50_wp * (hu(ji,jj) + sshn_u(ji,jj) + hu(ji,jj+1) + sshn_u(ji,jj+1))

            ! -advection (currently first order upwind)
            vv_s = (0.5_wp - SIGN(0.5_wp, v_s)) * vn(ji,jj)              + &
                 & (0.5_wp + SIGN(0.5_wp, v_s)) * vn(ji,jj-1)
            vv_n = (0.5_wp + SIGN(0.5_wp, v_n)) * vn(ji,jj)              + &
                 & (0.5_wp - SIGN(0.5_wp, v_n)) * vn(ji,jj+1)

            IF(pt(ji-1,jj) <= 0 .OR. pt(ji-1,jj+1) <= 0) THEN
               vv_w = (0.5_wp - SIGN(0.5_wp, u_w)) * vn(ji,jj)
            ELSE
               vv_w = (0.5_wp - SIGN(0.5_wp, u_w)) * vn(ji,jj)              + &
                    & (0.5_wp + SIGN(0.5_wp, u_w)) * vn(ji-1,jj)
            END If

            IF(pt(ji+1,jj) <= 0 .OR. pt(ji+1,jj+1) <= 0) THEN
               vv_e = (0.5_wp + SIGN(0.5_wp, u_e)) * vn(ji,jj)
            ELSE
               vv_e = (0.5_wp + SIGN(0.5_wp, u_e)) * vn(ji,jj)              + &
                    & (0.5_wp - SIGN(0.5_wp, u_e)) * vn(ji+1,jj)
            END IF

            adv = vv_w * u_w * depw - vv_e * u_e * depe + vv_s * v_s * deps - vv_n * v_n * depn

!end kernel v adv

            ! -viscosity

!kernel v dis
            dvdy_n = (vn(ji,jj+1) - vn(ji,  jj)) / e2t(ji,jj+1) * (ht(ji,jj+1) + sshn(ji,jj+1))
            dvdy_s = (vn(ji,  jj) - vn(ji,jj-1)) / e2t(ji,  jj) * (ht(ji,  jj) + sshn(ji,  jj))

            IF(pt(ji-1,jj) <= 0 .OR. pt(ji-1,jj+1) <= 0) THEN
              dvdx_w = 0.0_wp !slip boundary
            ELSE
              dvdx_w = (vn(ji,jj) - vn(ji-1,jj)) / (e1v(ji,jj) + e1v(ji-1,jj)) * &
                     & (hv(ji,jj) + sshn_v(ji,jj) + hv(ji-1,jj) + sshn_v(ji-1,jj))
            END IF

            IF(pt(ji+1,jj) <= 0 .OR. pt(ji+1,jj+1) <= 0) THEN
              dvdx_e = 0.0_wp ! slip boundary
            ELSE
              dvdx_e = (vn(ji+1,jj) - vn(ji,jj)) / (e1v(ji,jj) + e1v(ji+1,jj)) * &
                     & (hv(ji,jj) + sshn_v(ji,jj) + hv(ji+1,jj) + sshn_v(ji+1,jj))
            END If

            vis = (dvdy_n - dvdy_s ) * e1v(ji,jj)  + &
                & (dvdx_e - dvdx_w ) * e2v(ji,jj) * 0.5_wp

            vis = visc * vis   !visc will be a array visc(1:jpijglou)
                               !for variable viscosity, such as turbulent viscosity
!end kernel v dis

            ! -Coriolis' force (can be implemented implicitly)
!kernel v cor
            cor = -0.5_wp * (2._wp * omega * SIN(gphiv(ji,jj) * d2r) * (u_ec + u_wc)) * &
                & e12v(ji,jj) * (hv(ji,jj) + sshn_v(ji,jj))
!end kernel v cor

            ! -pressure gradient
!kernel v hpg
            hpg = -g * (hv(ji,jj) + sshn_v(ji,jj)) * e1v(ji,jj) * (sshn(ji,jj+1) - sshn(ji,jj))
!kernel v hpg

            ! -linear bottom friction (implemented implicitly.
!kernel ua calculation
            va(ji,jj) = (vn(ji,jj) * (hv(ji,jj) + sshn_v(ji,jj)) + rdt * (adv + vis + cor + hpg) / e12v(ji,jj) ) / &
                   & ((hv(ji,jj) + ssha_v(ji,jj))) / (1.0_wp + cbfr * rdt)
            END IF
!end kernel ua calculation

              rtmp1 = (sshn_u(ji  ,jj  ) + hu(ji  ,jj  )) * un(ji  ,jj  )
              rtmp2 = (sshn_u(ji-1,jj  ) + hu(ji-1,jj  )) * un(ji-1,jj  )
              rtmp3 = (sshn_v(ji  ,jj  ) + hv(ji  ,jj  )) * vn(ji  ,jj  )
              rtmp4 = (sshn_v(ji  ,jj-1) + hv(ji  ,jj-1)) * vn(ji  ,jj-1)
              ssha(ji,jj) = sshn(ji,jj) + (rtmp2 - rtmp1 + rtmp4 - rtmp3) * rdt / e12t(ji,jj)

          ! END IF
          END DO
          END DO
          ! END DO
          !$acc end kernels
          !$acc wait
        END SUBROUTINE momentum_acc

        attributes(global) SUBROUTINE momentum_ker(un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, &
                                                   hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, &
                                                   gphiu, gphiv, e12u, e12v, pt, ua, va ,&
                                                   visc, omega, d2r, g, rdt, cbfr, jpi, jpj)

          REAL(wp), intent(in), device, dimension(-31:jpi,1:jpj) :: un, hu, gphiu, e1u, e2u, sshn_u, ssha_u, e12u
          REAL(wp), intent(in), device, dimension(1:jpi,0:jpj)    :: vn, hv, gphiv, e1v, e2v, sshn_v, ssha_v, e12v
          REAL(wp), intent(in), device, dimension(1:jpi,1:jpj)    :: sshn, ht, e1t, e2t

          INTEGER, intent(in), device, dimension(0:jpi+1+30,0:jpj+1) :: pt
          INTEGER,  value, intent(in) :: jpi, jpj
          REAL(wp), value, intent(in) :: visc, omega, d2r, g, rdt, cbfr

          REAL(wp), intent(out), device, dimension(-31:jpi,1:jpj) :: ua
          REAL(wp), intent(out), device, dimension(1:jpi,0:jpj) :: va

          REAL(wp) :: u_e, u_w
          REAL(wp) :: v_s, v_n
          REAL(wp) :: v_sc, v_nc, u_ec, u_wc
          REAL(wp) :: uu_e, uu_w, uu_s, uu_n
          REAL(wp) :: vv_e, vv_w, vv_s, vv_n
          REAL(wp) :: depe, depw, deps, depn
          REAL(wp) :: dudx_e, dudy_n, dvdx_e, dvdy_n
          REAL(wp) :: dudx_w, dudy_s, dvdx_w, dvdy_s

          REAL(wp) :: adv, vis, hpg, cor
          INTEGER  :: ji, jj                          !temporary loop index

          ji = blockDim%x * (blockIdx%x - 1) + threadIdx%x
          jj = blockDim%y * (blockIdx%y - 1) + threadIdx%y

          ! Reads: un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, gphiu, gphiv, e12u, e12v (20)
          ! Reads (int): pt (1)
          ! Writes: ua, va (2)
          ! = 180 bytes
          ! For 1026x1026 = 181 MB, ie. 1ms if bandwidth bound.

          ! u equation
          ! !$acc kernels present(un, vn, hu, ht, sshn_u, sshn, e1t, e2t, e2u)
          ! !$acc loop collapse(2)
          ! DO jj = 1, jpj
          ! DO ji = 1, jpi
          IF (ji <= jpi .AND. jj <= jpj) THEN
! kernel u adv
             IF (ji <= jpi-1 .AND. &
               (pt(ji,jj) + pt(ji+1,jj) > 0) .AND. &                 !jump over non-computatinal domain
               (pt(ji,jj) > 0 .AND. pt(ji+1,jj) > 0))  THEN                    !jump over boundary u

             ! IF(pt(ji,jj) + pt(ji+1,jj) <= 0)  CYCLE                    !jump over non-computatinal domain
             ! IF(pt(ji,jj) <= 0 .OR. pt(ji+1,jj) <= 0)  CYCLE                    !jump over boundary u

             u_e  = 0.5 * (un(ji,jj) + un(ji+1,jj)) * e2t(ji+1,jj)      !add length scale.
             depe = ht(ji+1,jj) + sshn(ji+1,jj)

             u_w  = 0.5 * (un(ji,jj) + un(ji-1,jj)) * e2t(ji,jj)        !add length scale
             depw = ht(ji,jj) + sshn(ji,jj)

             v_sc = 0.5_wp * (vn(ji,jj-1) + vn(ji+1,jj-1))
             v_s  = 0.5_wp * v_sc * (e1v(ji,jj-1) + e1v(ji+1,jj-1))
             deps = 0.5_wp * (hv(ji,jj-1) + sshn_v(ji,jj-1) + hv(ji+1,jj-1) + sshn_v(ji+1,jj-1))

             v_nc = 0.5_wp * (vn(ji,jj) + vn(ji+1,jj))
             v_n  = 0.5_wp * v_nc * (e1v(ji,jj) + e1v(ji+1,jj))
             depn = 0.5_wp * (hv(ji,jj) + sshn_v(ji,jj) + hv(ji+1,jj) + sshn_v(ji+1,jj))

            ! -advection (currently first order upwind)
            uu_w = (0.5_wp - SIGN(0.5_wp, u_w)) * un(ji,jj)              + &
                 & (0.5_wp + SIGN(0.5_wp, u_w)) * un(ji-1,jj)
            uu_e = (0.5_wp + SIGN(0.5_wp, u_e)) * un(ji,jj)              + &
                 & (0.5_wp - SIGN(0.5_wp, u_e)) * un(ji+1,jj)

            ! if (u_w >= 0) THEN
               ! uu_w = un(ji,jj)
            ! else
               ! uu_w = un(ji-1,jj)
            ! END IF
            ! if (u_e >= 0) THEN
               ! uu_e = un(ji,jj)
            ! else
               ! uu_e = un(ji+1,jj)
            ! END IF

            IF(pt(ji,jj-1) <=0 .OR. pt(ji+1,jj-1) <= 0) THEN
               uu_s = (0.5_wp - SIGN(0.5_wp, v_s)) * un(ji,jj)
            ELSE
               uu_s = (0.5_wp - SIGN(0.5_wp, v_s)) * un(ji,jj)              + &
                    & (0.5_wp + SIGN(0.5_wp, v_s)) * un(ji,jj-1)
            END If

            IF(pt(ji,jj+1) <=0 .OR. pt(ji+1,jj+1) <= 0) THEN
               uu_n = (0.5_wp + SIGN(0.5_wp, v_n)) * un(ji,jj)
            ELSE
               uu_n = (0.5_wp + SIGN(0.5_wp, v_n)) * un(ji,jj)              + &
                    & (0.5_wp - SIGN(0.5_wp, v_n)) * un(ji,jj+1)
            END IF

            adv = uu_w * u_w * depw - uu_e * u_e * depe + uu_s * v_s * deps - uu_n * v_n * depn
!end kernel u adv

            ! -viscosity

!kernel  u vis
            dudx_e = (un(ji+1,jj) - un(ji,  jj)) / e1t(ji+1,jj) * (ht(ji+1,jj) + sshn(ji+1,jj))
            dudx_w = (un(ji,  jj) - un(ji-1,jj)) / e1t(ji,  jj) * (ht(ji,  jj) + sshn(ji,  jj))
            IF(pt(ji,jj-1) <=0 .OR. pt(ji+1,jj-1) <= 0) THEN
              dudy_s = 0.0_wp !slip boundary
            ELSE
              dudy_s = (un(ji,jj) - un(ji,jj-1)) / (e2u(ji,jj) + e2u(ji,jj-1)) * &
                     & (hu(ji,jj) + sshn_u(ji,jj) + hu(ji,jj-1) + sshn_u(ji,jj-1))
            END IF

            IF(pt(ji,jj+1) <= 0 .OR. pt(ji+1,jj+1) <= 0) THEN
              dudy_n = 0.0_wp ! slip boundary
            ELSE
              dudy_n = (un(ji,jj+1) - un(ji,jj)) / (e2u(ji,jj) + e2u(ji,jj+1)) * &
                     & (hu(ji,jj) + sshn_u(ji,jj) + hu(ji,jj+1) + sshn_u(ji,jj+1))
            END If

            vis = (dudx_e - dudx_w ) * e2u(ji,jj)  + &
                & (dudy_n - dudy_s ) * e1u(ji,jj) * 0.5_wp
            vis = visc * vis   !visc will be an array visc(1:jpijglou)
                               !for variable viscosity, such as turbulent viscosity
!End  kernel u vis

            ! -Coriolis' force (can be implemented implicitly)
!kernel cor
            cor = 0.5_wp * (2._wp * omega * SIN(gphiu(ji,jj) * d2r) * (v_sc + v_nc)) * &
                & e12u(ji,jj) * (hu(ji,jj) + sshn_u(ji,jj))
!end kernel cor

            ! -pressure gradient
!start kernel hpg
            hpg = -g * (hu(ji,jj) + sshn_u(ji,jj)) * e2u(ji,jj) * (sshn(ji+1,jj) - sshn(ji,jj))
!end kernel hpg
            ! -linear bottom friction (implemented implicitly.
!kernel ua calculation
            ua(ji,jj) = (un(ji,jj) * (hu(ji,jj) + sshn_u(ji,jj)) + rdt * (adv + vis + cor + hpg) / e12u(ji,jj)) / &
                   & (hu(ji,jj) + ssha_u(ji,jj)) / (1.0_wp + cbfr * rdt)
!end kernel ua
            END IF
          ! END DO
          ! END DO

          ! v equation
          ! DO jj = 1, jpj
          ! DO ji = 1, jpi

             IF (jj <= jpj-1 .AND. &
               pt(ji,jj) + pt(ji+1,jj) >= 0 .AND. &                         !jump over non-computatinal domain
               (pt(ji,jj) > 0 .AND. pt(ji,jj+1) > 0))  THEN                !jump over v boundary cells

             ! IF(pt(ji,jj) + pt(ji+1,jj) <= 0)  CYCLE                    !jump over non-computatinal domain
             ! IF(pt(ji,jj) <= 0 .OR. pt(ji,jj+1) <= 0)  CYCLE                !jump over v boundary cells

! kernel v adv
             v_n  = 0.5 * (vn(ji,jj) + vn(ji,jj+1)) * e1t(ji,jj+1)  !add length scale.
             depn = ht(ji,jj+1) + sshn(ji,jj+1)

             v_s  = 0.5 * (vn(ji,jj) + vn(ji,jj-1)) * e1t(ji,jj)    !add length scale
             deps = ht(ji,jj) + sshn(ji,jj)

             u_wc = 0.5_wp * (un(ji-1,jj) + un(ji-1,jj+1))
             u_w  = 0.5_wp * u_wc * (e2u(ji-1,jj) + e2u(ji-1,jj+1))
             depw = 0.50_wp * (hu(ji-1,jj) + sshn_u(ji-1,jj) + hu(ji-1,jj+1) + sshn_u(ji-1,jj+1))

             u_ec = 0.5_wp * (un(ji,jj) + un(ji,jj+1))
             u_e  = 0.5_wp * u_ec * (e2u(ji,jj) + e2u(ji,jj+1))
             depe = 0.50_wp * (hu(ji,jj) + sshn_u(ji,jj) + hu(ji,jj+1) + sshn_u(ji,jj+1))

            ! -advection (currently first order upwind)
            vv_s = (0.5_wp - SIGN(0.5_wp, v_s)) * vn(ji,jj)              + &
                 & (0.5_wp + SIGN(0.5_wp, v_s)) * vn(ji,jj-1)
            vv_n = (0.5_wp + SIGN(0.5_wp, v_n)) * vn(ji,jj)              + &
                 & (0.5_wp - SIGN(0.5_wp, v_n)) * vn(ji,jj+1)

            ! if (v_s >= 0) THEN
               ! vv_s = vn(ji,jj)
            ! else
               ! vv_s = vn(ji,jj-1)
            ! END IF
            ! if (v_n >= 0) THEN
               ! vv_n = vn(ji,jj)
            ! else
               ! vv_n = vn(ji,jj+1)
            ! END IF

            IF(pt(ji-1,jj) <= 0 .OR. pt(ji-1,jj+1) <= 0) THEN
               vv_w = (0.5_wp - SIGN(0.5_wp, u_w)) * vn(ji,jj)
            ELSE
               vv_w = (0.5_wp - SIGN(0.5_wp, u_w)) * vn(ji,jj)              + &
                    & (0.5_wp + SIGN(0.5_wp, u_w)) * vn(ji-1,jj)
            END If

            IF(pt(ji+1,jj) <= 0 .OR. pt(ji+1,jj+1) <= 0) THEN
               vv_e = (0.5_wp + SIGN(0.5_wp, u_e)) * vn(ji,jj)
            ELSE
               vv_e = (0.5_wp + SIGN(0.5_wp, u_e)) * vn(ji,jj)              + &
                    & (0.5_wp - SIGN(0.5_wp, u_e)) * vn(ji+1,jj)
            END IF

            adv = vv_w * u_w * depw - vv_e * u_e * depe + vv_s * v_s * deps - vv_n * v_n * depn

!end kernel v adv

            ! -viscosity

!kernel v dis
            dvdy_n = (vn(ji,jj+1) - vn(ji,  jj)) / e2t(ji,jj+1) * (ht(ji,jj+1) + sshn(ji,jj+1))
            dvdy_s = (vn(ji,  jj) - vn(ji,jj-1)) / e2t(ji,  jj) * (ht(ji,  jj) + sshn(ji,  jj))

            IF(pt(ji-1,jj) <= 0 .OR. pt(ji-1,jj+1) <= 0) THEN
              dvdx_w = 0.0_wp !slip boundary
            ELSE
              dvdx_w = (vn(ji,jj) - vn(ji-1,jj)) / (e1v(ji,jj) + e1v(ji-1,jj)) * &
                     & (hv(ji,jj) + sshn_v(ji,jj) + hv(ji-1,jj) + sshn_v(ji-1,jj))
            END IF

            IF(pt(ji+1,jj) <= 0 .OR. pt(ji+1,jj+1) <= 0) THEN
              dvdx_e = 0.0_wp ! slip boundary
            ELSE
              dvdx_e = (vn(ji+1,jj) - vn(ji,jj)) / (e1v(ji,jj) + e1v(ji+1,jj)) * &
                     & (hv(ji,jj) + sshn_v(ji,jj) + hv(ji+1,jj) + sshn_v(ji+1,jj))
            END If

            vis = (dvdy_n - dvdy_s ) * e1v(ji,jj)  + &
                & (dvdx_e - dvdx_w ) * e2v(ji,jj) * 0.5_wp

            vis = visc * vis   !visc will be a array visc(1:jpijglou)
                               !for variable viscosity, such as turbulent viscosity
!end kernel v dis

            ! -Coriolis' force (can be implemented implicitly)
!kernel v cor
            cor = -0.5_wp * (2._wp * omega * SIN(gphiv(ji,jj) * d2r) * (u_ec + u_wc)) * &
                & e12v(ji,jj) * (hv(ji,jj) + sshn_v(ji,jj))
!end kernel v cor

            ! -pressure gradient
!kernel v hpg
            hpg = -g * (hv(ji,jj) + sshn_v(ji,jj)) * e1v(ji,jj) * (sshn(ji,jj+1) - sshn(ji,jj))
!kernel v hpg

            ! -linear bottom friction (implemented implicitly.
!kernel ua calculation
            va(ji,jj) = (vn(ji,jj) * (hv(ji,jj) + sshn_v(ji,jj)) + rdt * (adv + vis + cor + hpg) / e12v(ji,jj) ) / &
                   & ((hv(ji,jj) + ssha_v(ji,jj))) / (1.0_wp + cbfr * rdt)
            END IF
!end kernel ua calculation
          ! END DO
          ! END DO
          END IF
          ! !$acc end kernels
          ! !$acc wait
        END SUBROUTINE momentum_ker

     end module cuda_mod

PROGRAM nemolite2d

         !!! A Horizontal 2D hydrodynamic ocean model which
         !!   1) using structured grid
         !!   2) using direct data addressig structures
         use timing_mod
         use field_mod
         use gocean_mod,      only: model_write_log
         use cuda_mod
         use cudafor
         use sizes_mod
         IMPLICIT NONE

         REAL(wp), PARAMETER :: pi    = 3.1415926535897932_wp
         REAL(wp), PARAMETER :: g     = 9.80665_wp                          ! gravity constant
         REAL(wp), PARAMETER :: omega = 7.292116e-05_wp                     ! earth rotation speed (s^(-1))
         REAL(wp), PARAMETER :: d2r   = pi / 180._wp                        ! degree to radian

         INTEGER, ALLOCATABLE :: pt(:,:)                                    ! properties of t-cells
                                                                            ! 1: water cell within computational domain
                                                                            ! 0: land cell
                                                                            !-1: water cell outside computational domain

         REAL(wp), ALLOCATABLE :: e1t(:,:), e2t(:,:), e1u(:,:), e2u(:,:)
         REAL(wp), ALLOCATABLE :: e1f(:,:), e2f(:,:), e1v(:,:), e2v(:,:)
         REAL(wp), ALLOCATABLE :: e12t(:,:), e12u(:,:), e12v(:,:)

         REAL(wp), ALLOCATABLE :: gphiu(:,:), gphiv(:,:), gphif(:,:)

         REAL(wp), ALLOCATABLE :: xt(:,:), yt(:,:)

         REAL(wp), ALLOCATABLE :: ht(:,:), hu(:,:), hv(:,:), hf(:,:)

         REAL(wp), ALLOCATABLE :: sshb(:,:), sshb_u(:,:), sshb_v(:,:)
         REAL(wp), ALLOCATABLE :: sshn(:,:), sshn_u(:,:), sshn_v(:,:)
         REAL(wp), ALLOCATABLE :: ssha(:,:), ssha_u(:,:), ssha_v(:,:)

         REAL(wp), ALLOCATABLE :: un(:,:),  vn(:,:), ua(:,:),  va(:,:)

         INTEGER  :: jpiglo, jpjglo, jpi, jpj        !dimensions of grid
         INTEGER  :: jphgr_msh                       !type of grid
         INTEGER  :: nit000, nitend, irecord         !start-end and record time steps

         REAL(wp) :: dx, dy, dep_const               !regular grid size and constant depth
         REAL(wp) :: rdt                             !time step

         REAL(wp) :: cbfr                            !bottom friction coefficient
         REAL(wp) :: visc                            !backgroud/constant viscosity

         INTEGER  :: istp                            !time stepping index

         INTEGER  :: itmp1, itmp2                    !integer temporary vars
         integer :: idxt ! Index for main-loop timer

         !! read in model parameters
         CALL setup

         !! allocate memory and read in or setup model grid
         CALL grid

         !! setup model initial condition
         CALL initialisation

         istp = 0
         CALL output

         call acc_init()

         !$acc data pcopy(pt) &
         !$acc      pcopy(e1t, e2t, e1u, e2u) &
         !$acc      pcopy(e1f, e2f, e1v, e2v) &
         !$acc      pcopy(e12t, e12u, e12v) &
         !$acc      pcopy(gphiu, gphiv, gphif) &
         !$acc      pcopy(xt, yt) &
         !$acc      pcopy(ht, hu, hv, hf ) &
         !$acc      pcopy(sshb, sshb_u, sshb_v) &
         !$acc      pcopy(sshn, sshn_u, sshn_v) &
         !$acc      pcopy(ssha, ssha_u, ssha_v) &
         !$acc      pcopy(un,  vn, ua,  va)

         call timer_start('Time-stepping', idxt, (nitend-nit000+1))

         !! time stepping
         DO istp = nit000, nitend, 1
           !print*, 'istp == ', istp
           CALL step
         END DO

         call timer_stop(idxt)
         !$acc end data

         ! Compute and output some checksums for error checking
         call model_write_log("('ua checksum = ',E16.8)", &
                              field_checksum(ua(1:jpiglo,1:jpjglo)) )
         call model_write_log("('va checksum = ',E16.8)", &
                              field_checksum(va(1:jpiglo,1:jpjglo)))

         !! finalise the model run
         CALL finalisation

         ! WRITE(*,*) 'Simulation finished!!'
         ! WRITE(*,*)
!-----------------------------------
CONTAINS

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE setup
          INTEGER :: ios

          !! Read in model setup parameters
          NAMELIST/namctl/ jpiglo, jpjglo, jphgr_msh, &
            &              dx    , dy    , dep_const, &
            &              nit000, nitend, irecord  , &
            &              rdt   , cbfr  , visc

          !! Default value

          jpiglo      =     258               !  number of columns of model grid
          jpjglo      =     258               !  number of rows of model grid
          jphgr_msh   =       1               !  type of grid (0: read in a data file; 1: setup with following parameters)
          dx          =   1000._wp            !  grid size in x direction (m)
          dy          =   1000._wp            !  grid size in y direction (m)
          dep_const   =    100._wp            !  constant depth (m)
          nit000      =       1               !  first time step
          nitend      =    1000               !  end time step
          irecord     =       1               !  intervals to save results
          rdt         =     10._wp            !  size of time step (second)
          cbfr        =   0.001_wp            !  bottom friction coefficeint
          visc        =     100._wp            !  horizontal kinematic viscosity coefficient

          OPEN(1, file='namelist', STATUS='OLD')
          REWIND(1)
          READ(1, NML=namctl, IOSTAT = ios, ERR = 901)
901       IF(ios /= 0) STOP "err found in reading namelist file"
          WRITE(*,NML=namctl)

          ! This correction is to allow the same format namelist file for this
          ! 'original' version of the code and the PSyKAl version. The original
          ! version implicitly adds on the boundaries to the specified domain
          ! whereas in the psykal version the user explicitly specifies the
          ! extent of the domain including boundaries. This is to ensure
          ! consistency with future developments where the T-mask defining the
          ! domain may be read from file.
          jpiglo = jpiglo - 2
          jpjglo = jpjglo - 2

          jpi = jpiglo
          jpj = jpjglo

          CLOSE(1)

        END SUBROUTINE setup

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE grid
           INTEGER  :: ji, jj                          !temporary loop index

        !  need a kernel for boundary /grid
          !! Allocate working arrays
          !! Define (or read in) model grid

          !jphgr_msh = 0    ! read in this from a namelist file
          !jphgr_msh = 1    ! define manually

          SELECT CASE( jphgr_msh)

          CASE(0) ! read in grid from a coordinate file

            ! to be added
            STOP "It is not ready to Read in grid from a file"
            CALL allocation
            ! add reading data part here
            ! the following variables/arrays are needed:
            ! jpi, jpj,
            ! pt(0:jpi+1)
            ! e1t(jpi,    jpj), e2t(jpi,    jpj)
            ! e1u(0:jpi,  jpj), e2u(0:jpi,  jpj)
            ! e1v(jpi,  0:jpj), e2v(jpi,  0:jpj)
            ! e1f(0:jpi,0:jpj), e2f(0:jpi,0:jpj)
            ! gphiu(0:jpi,jpj), gphiv(jpi,0:jpj), gphif(0:jpi,0:jpj)
            ! xt(jpi,jpj), yt(jpi,jpj)
            ! ht(jpi,jpj), hu(jpi,jpj), hv(jpi,jpj)

          CASE(1)

            !##### a manually defined grid

            ! -size of each grid cell
            ! -depth on each T points
            ! -grid dimension

            CALL allocation

            !Define Model solid/open Boundaries via the properties of t-cells
            DO jj = 0, jpj+1
              DO ji = 0, jpi+1
                pt(ji,jj) = 1                             ! all inner celles
              END DO
            END DO

            ! -define solid/open boundaries
            DO jj = 0, jpj+1
              pt(0,    jj) = 0                            ! west solid boundary
              pt(jpi+1,jj) = 0                            ! east solid boundary
            END Do

            DO ji = 0, jpi+1
              pt(ji,jpj+1) = 0                            ! north solid boundary
            END Do

            DO ji = 1, jpi
              pt(ji,0) = -1                               ! south open boundary
            END Do

            !horizontal grid cells

            ! -horizontal scales of grid cells
            ! -Latititude of grid points
            ! -horizontal coordinates of grid points

            e1t(1:jpi, 1:jpj)   = dx
            e2t(1:jpi, 1:jpj)   = dy
            e1u(0:jpi, 1:jpj)   = dx
            e2u(0:jpi, 1:jpj)   = dy
            e1v(1:jpi, 0:jpj)   = dx
            e2v(1:jpi, 0:jpj)   = dy
            e1f(0:jpi, 0:jpj)   = dx
            e2f(0:jpi, 0:jpj)   = dy

            ! -here is a f-plane testing case
            gphiu(0:jpi, 1:jpj) = 50._wp
            gphiv(1:jpi, 0:jpj) = 50._wp
            gphif(0:jpi, 0:jpj) = 50._wp

            xt(1,:) = 0.0_wp + 0.5_wp * e1t(1,:)
            yt(:,1) = 0.0_wp + 0.5_wp * e2t(:,1)

            DO ji = 2, jpi
              xt(ji,1:jpj) = xt(ji-1, 1:jpj) + dx
            END DO

            DO jj = 2, jpj
              yt(1:jpi,jj) = yt(1:jpi, jj-1) + dy
            END DO
            !Depth

            ! -depth on grid points

            DO jj = 1, jpj
            DO ji = 1, jpi
              ht(ji,jj) = dep_const
            END DO
            END DO

            DO jj = 1, jpj
            DO ji = 0, jpi
              hu(ji,jj) = dep_const
            END DO
            END DO

            DO jj = 0, jpj
            DO ji = 1, jpi
              hv(ji,jj) = dep_const
            END DO
            END DO

          CASE DEFAULT
            ! undefined jphgr_msh value
            ! add interrupt here
            STOP "Wrong grid defination type, check your setup !!!!"
          END SELECT

          ! calculate t,u,v cell area
          DO jj = 1, jpj
            DO ji = 1, jpi
              e12t(ji,jj) = e1t(ji,jj) * e2t(ji,jj)
            END DO
          END DO

          DO jj = 1, jpj
            DO ji = 0, jpi
              e12u(ji,jj) = e1u(ji,jj) * e2u(ji,jj)
            END DO
          END DO

          DO jj = 0, jpj
            DO ji = 1, jpi
              e12v(ji,jj) = e1v(ji,jj) * e2v(ji,jj)
            END DO
          END DO

        END SUBROUTINE grid

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE allocation
          !! Read in model setup parameters and allocate working arrays
          INTEGER :: ierr(11)
          REAL(wp) :: init_val

          IF (MODULO(jpi, 32) /= 0) THEN
             ALLOCATE(e1t(jpi,jpj), e2t(jpi,jpj), e1u(0:jpi,jpj), e2u(0:jpi,jpj), STAT=ierr(1))
             ALLOCATE(e1f(0:jpi,0:jpj), e2f(0:jpi,0:jpj), e1v(jpi,0:jpj), e2v(jpi,0:jpj), STAT=ierr(2))
             ALLOCATE(e12t(jpi,jpj), e12u(0:jpi,jpj), e12v(jpi,0:jpj), STAT=ierr(3))

             ALLOCATE(gphiu(0:jpi,jpj), gphiv(jpi,0:jpj), gphif(0:jpi,0:jpj), STAT=ierr(4))

             ALLOCATE(xt(jpi,jpj), yt(jpi,jpj), STAT=ierr(5))

             ALLOCATE(ht(jpi,jpj), hu(0:jpi,jpj), hv(jpi,0:jpj), hf(0:jpi,0:jpj), STAT=ierr(6))

             ALLOCATE(sshb(jpi,jpj), sshb_u(0:jpi,jpj), sshb_v(jpi,0:jpj), STAT=ierr(7))
             ALLOCATE(sshn(jpi,jpj), sshn_u(0:jpi,jpj), sshn_v(jpi,0:jpj), STAT=ierr(8))
             ALLOCATE(ssha(jpi,jpj), ssha_u(0:jpi,jpj), ssha_v(jpi,0:jpj), STAT=ierr(9))

             ALLOCATE(un(0:jpi,jpj), vn(jpi,0:jpj), ua(0:jpi,jpj), va(jpi,0:jpj), STAT=ierr(10))

             ALLOCATE(pt(0:jpi+1,0:jpj+1), STAT=ierr(11))

          ELSE
             ! Pad the allocations. TODO: Make this more generic rather than lazy
             ALLOCATE(e1t(jpi,jpj), e2t(jpi,jpj), e1u(-31:jpi,jpj), e2u(-31:jpi,jpj), STAT=ierr(1))
             ALLOCATE(e1f(-31:jpi,0:jpj), e2f(-31:jpi,0:jpj), e1v(jpi,0:jpj), e2v(jpi,0:jpj), STAT=ierr(2))
             ALLOCATE(e12t(jpi,jpj), e12u(-31:jpi,jpj), e12v(jpi,0:jpj), STAT=ierr(3))

             ALLOCATE(gphiu(-31:jpi,jpj), gphiv(jpi,0:jpj), gphif(-31:jpi,0:jpj), STAT=ierr(4))

             ALLOCATE(xt(jpi,jpj), yt(jpi,jpj), STAT=ierr(5))

             ALLOCATE(ht(jpi,jpj), hu(-31:jpi,jpj), hv(jpi,0:jpj), hf(-31:jpi,0:jpj), STAT=ierr(6))

             ALLOCATE(sshb(jpi,jpj), sshb_u(-31:jpi,jpj), sshb_v(jpi,0:jpj), STAT=ierr(7))
             ALLOCATE(sshn(jpi,jpj), sshn_u(-31:jpi,jpj), sshn_v(jpi,0:jpj), STAT=ierr(8))
             ALLOCATE(ssha(jpi,jpj), ssha_u(-31:jpi,jpj), ssha_v(jpi,0:jpj), STAT=ierr(9))

             ALLOCATE(un(-31:jpi,jpj), vn(jpi,0:jpj), ua(-31:jpi,jpj), va(jpi,0:jpj), STAT=ierr(10))

             ALLOCATE(pt(0:jpi+1+30,0:jpj+1), STAT=ierr(11))
          END IF

          IF(ANY(ierr /= 0, 1)) STOP "in SUBROUTINE ALLOCATION: failed to allocate arrays"

          ! Initialise all solution arrays
          init_val = -999.0
          ht = init_val ; hu = init_val ; hv = init_val ; hf = init_val
          sshb = init_val ; sshb_u = init_val ; sshb_v = init_val
          sshn = init_val ; sshn_u = init_val ; sshn_v = init_val
          ssha = init_val ; ssha_u = init_val ; ssha_v = init_val
          un = init_val ; vn = init_val ; ua = init_val ; va = init_val

        END SUBROUTINE allocation

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE initialisation
          INTEGER  :: ji, jj                          !temporary loop index
          REAL(wp) :: rtmp1, rtmp2, rtmp3, rtmp4      !real temporary variables

          call timer_init()

          ! define (or read in) initil ssh and velocity fields
!         ! split this part into ssh, sshu, sshv, u, v kernels
            DO ji=1,jpi
              DO jj =1, jpj
                sshn(ji,jj) = 0.0_wp
              END DO
            END DO

            DO ji=0,jpi
              DO jj =1, jpj
                itmp1 = min(ji+1,jpi)
                itmp2 = max(ji,1)
                rtmp1 = e12t(itmp1,jj) * sshn(itmp1,jj) + e12t(itmp2,jj) * sshn(itmp2,jj)
                sshn_u(ji,jj) = 0.5_wp * rtmp1 / e12u(ji,jj)
              END DO
            END DO

            DO ji=1,jpi
              DO jj =0, jpj
                itmp1 = min(jj+1,jpj)
                itmp2 = max(jj,1)
                rtmp1 = e12t(ji,itmp1) * sshn(ji,itmp1) + e12t(ji,itmp2) * sshn(ji,itmp2)
                sshn_v(ji,jj) = 0.5_wp * rtmp1 / e12v(ji,jj)
              END DO
            END DO

            DO jj =1, jpj
              DO ji=0,jpi
                 un(ji,jj) = 0._wp
              END DO
            END DO

            DO jj =0, jpj
              DO ji=1,jpi
                 vn(ji,jj) = 0._wp
              END DO
            END DO

! This call updates 'a' quantities which are not used before the code
! in step again updates them. Therefore I think it does nothing. ARP.
!            CALL bc(0._wp)

        END SUBROUTINE initialisation

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE step
          REAL(wp) :: rtime

          rtime = REAL(istp, wp) * rdt

          CALL continuity
          CALL momentum
          CALL bc(rtime)  ! open and solid boundary condition
          CALL next
          IF(MOD(istp, irecord) == 0)  CALL output

        END SUBROUTINE step

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE continuity
          INTEGER  :: ji, jj                          !temporary loop index
          REAL(wp) :: rtmp1, rtmp2, rtmp3, rtmp4      !real temporary variables
          return
!kernel continuity
          ! Going at 198 GB/s. Fusion?
          !$acc kernels
          ! acc loop collapse(2)
          DO jj = 1, jpj
            DO ji = 1, jpi
              rtmp1 = (sshn_u(ji  ,jj  ) + hu(ji  ,jj  )) * un(ji  ,jj  )
              rtmp2 = (sshn_u(ji-1,jj  ) + hu(ji-1,jj  )) * un(ji-1,jj  )
              rtmp3 = (sshn_v(ji  ,jj  ) + hv(ji  ,jj  )) * vn(ji  ,jj  )
              rtmp4 = (sshn_v(ji  ,jj-1) + hv(ji  ,jj-1)) * vn(ji  ,jj-1)
              ssha(ji,jj) = sshn(ji,jj) + (rtmp2 - rtmp1 + rtmp4 - rtmp3) * rdt / e12t(ji,jj)
            END DO
          END DO
          !$acc end kernels
!end kernel continuity
        END SUBROUTINE continuity

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE momentum
          use cuda_mod

          TYPE(dim3) gridDim1
          TYPE(dim3) gridDim2
          TYPE(dim3) blockDim1
          TYPE(dim3) blockDim2

          integer istat

         INTERFACE
           SUBROUTINE momentum_c(un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, &
                                                   hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, &
                                                   gphiu, gphiv, e12u, e12v, pt, ua, va, &
                                                   ssha, e12t, &
                                                   visc, omega, d2r, g, rdt, cbfr, jpi, jpj) bind(C, name="momentum_c_")
             USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_INT
             use sizes_mod
             IMPLICIT NONE
             REAL(wp), intent(in), device, dimension(:,:) :: un, hu, gphiu, e1u, e2u, sshn_u, ssha_u, e12u
             REAL(wp), intent(in), device, dimension(:,:)    :: vn, hv, gphiv, e1v, e2v, sshn_v, ssha_v, e12v
             REAL(wp), intent(in), device, dimension(:,:)    :: ssha, sshn, ht, e1t, e2t, e12t

             INTEGER(C_INT), intent(in), device, dimension(:,:) :: pt
             INTEGER(C_INT), value, intent(in) :: jpi, jpj
             REAL(wp), value, intent(in) :: visc, omega, d2r, g, rdt, cbfr

             REAL(wp), intent(out), device, dimension(:,:) :: ua
             REAL(wp), intent(out), device, dimension(:,:) :: va
           END SUBROUTINE momentum_c
         END INTERFACE

          blockDim1%x = 128
          blockDim2%x = 128
          blockDim1%y = 1
          blockDim2%y = 1

          gridDim1%x = jpi / blockDim1%x
          gridDim2%x = jpi / blockDim2%x
          gridDim1%y = jpj / (blockDim1%y)
          gridDim2%y = jpj / (blockDim2%y)

          !$acc host_data use_device(un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, gphiu, gphiv, e12u, e12v, pt, ua, va, ssha, e12t)
          !call momentum_ker <<< gridDim1, blockDim1 >>>(un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, &
          !                                             hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, &
          !                                             gphiu, gphiv, e12u, e12v, pt, ua, va, &
          !                                             visc, omega, d2r, g, rdt, cbfr, jpi, jpj)
          call momentum_acc(un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, &
                            hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, &
                            gphiu, gphiv, e12u, e12v, pt, ua, va, &
                            ssha, e12t, &
                            visc, omega, d2r, g, rdt, cbfr, jpi, jpj)

          ! call momentum_c(un, vn, sshn, sshn_u, sshn_v, ssha_u, ssha_v, &
                                                      ! hu, hv, ht, e1v, e2v, e1u, e2u, e1t, e2t, &
                                                      ! gphiu, gphiv, e12u, e12v, pt, ua, va, &
                                                      ! ssha, e12t, &
                                                      ! visc, omega, d2r, g, rdt, cbfr, jpi, jpj)
          !$acc end host_data
          istat = cudaDeviceSynchronize()
        END SUBROUTINE momentum

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE bc(rtime)
          REAL(wp), INTENT(IN) :: rtime
          REAL(wp) :: amp_tide, omega_tide
          INTEGER :: jiu, jiv
          INTEGER  :: ji, jj                          !temporary loop index

          !open boundary condition of clamped ssh

!kernel ssh clamped obc
            amp_tide   = 0.2_wp
            omega_tide = 2.0_wp * 3.14159_wp / (12.42_wp * 3600._wp)
            !$acc kernels
            ! acc loop collapse(2)
            DO jj = 1, jpj
              DO ji = 1, jpi
                IF(pt(ji,jj) <= 0) CYCLE
                IF     (pt(ji,jj-1) < 0) THEN
                  ssha(ji,jj) = amp_tide * sin(omega_tide * rtime)
                ELSE IF(pt(ji,jj+1) < 0) THEN
                  ssha(ji,jj) = amp_tide * sin(omega_tide * rtime)
                ELSE IF(pt(ji+1,jj) < 0) THEN
                  ssha(ji,jj) = amp_tide * sin(omega_tide * rtime)
                ELSE IF(pt(ji-1,jj) < 0) THEN
                  ssha(ji,jj) = amp_tide * sin(omega_tide * rtime)
                END IF
              END DO
            END DO
!end kernel ssh clamped obc

! kernel"solid boundary conditions for u-velocity"
            ! !$acc loop collapse(2)
            ! DO jj = 1, jpj
              ! DO ji = 0, jpi
                ! IF(pt(ji,jj) * pt(ji+1,jj) == 0) ua(ji,jj) = 0._wp
              ! END DO
            ! END DO
!end kernel "solid boundary conditions for u-velocity"

!kernel "solid boundary conditions for v-velocity"
            ! !$acc loop collapse(2)
            ! DO jj = 0, jpj
              ! DO ji = 1, jpi
                ! IF(pt(ji,jj) * pt(ji,jj+1) == 0) va(ji,jj) = 0._wp
              ! END DO
            ! END DO
!end kernel "solid boundary conditions for v-velocity"

          !                                            Du                 Dssh
          !start of "Flather open boundary condition [---- = sqrt(g/H) * ------]" Kernel
          !                                            Dn                 Dn
          ! ua and va in du/dn should be the specified tidal forcing

! kernel Flather u
            DO jj = 1, jpj
              ! acc loop independent
              DO ji = 0, jpi
                IF(pt(ji,jj) * pt(ji+1,jj) == 0) ua(ji,jj) = 0._wp
                IF(pt(ji,jj) + pt(ji+1,jj) <= -1) CYCLE                         ! not in the domain
                IF(pt(ji,jj) < 0) THEN
                  jiu = ji + 1
                  ua(ji,jj) = ua(jiu,jj) + SQRT(g/hu(ji,jj)) * (sshn_u(ji,jj) - sshn_u(jiu,jj))
                ELSE IF(pt(ji+1,jj )< 0) THEN
                  jiu = ji - 1
                  ua(ji,jj) = ua(jiu,jj) + SQRT(g/hu(ji,jj)) * (sshn_u(ji,jj) - sshn_u(jiu,jj))
                END IF
              END DO
            END DO
!end kernel flather u .

!kernel Flather v
            ! acc loop independent
            DO jj = 0, jpj
              DO ji = 1, jpi
                IF(pt(ji,jj) * pt(ji,jj+1) == 0) va(ji,jj) = 0._wp
                IF(pt(ji,jj) + pt(ji,jj+1) <= -1) CYCLE                         ! not in the domain
                IF(pt(ji,jj) < 0) THEN
                  jiv = jj + 1
                  va(ji,jj) = va(ji,jiv) + SQRT(g/hv(ji,jj)) * (sshn_v(ji,jj) - sshn_v(ji,jiv))
                ELSE IF(pt(ji,jj+1) < 0) THEN
                  jiv = jj - 1
                  va(ji,jj) = va(ji,jiv) + SQRT(g/hv(ji,jj)) * (sshn_v(ji,jj) - sshn_v(ji,jiv))
                END IF
              END DO
            END DO
            !$acc end kernels
!end kernel flather v .

        END SUBROUTINE bc

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE next
          ! update the now-velocity and ssh
          INTEGER  :: ji, jj                          !temporary loop index
          REAL(wp) :: rtmp1, rtmp2, rtmp3, rtmp4      !real temporary variables

! kernel  un updating
          !$acc kernels present(e12t, sshn)
          ! acc loop collapse(2)
          DO jj = 1, jpj
            DO ji = 0, jpi
              un(ji,jj)   = ua(ji,jj)
            END DO
          END DO
! end of kernel sshn_u updating.

! kernel vn updating
          ! acc loop collapse(2)
          DO jj = 0, jpj
            DO ji = 1, jpi
              vn(ji,jj)   = va(ji,jj)
            END DO
          END DO
! end kernel vn updating.

! kernel sshn updating
          ! acc loop collapse(2)
          DO jj = 1, jpj
            DO ji = 1, jpi
              sshn(ji,jj) = ssha(ji,jj)
            END DO
          END DO
! end kernel sshn_u updating.

! kernel sshn_u updating
          ! acc loop collapse(2)
          DO jj = 1, jpj
            DO ji = 0, jpi
              IF(pt(ji,jj) + pt(ji+1,jj) <= 0)  CYCLE                              !jump over non-computational domain
              IF(pt(ji,jj) * pt(ji+1,jj) > 0) THEN
                rtmp1 = e12t(ji,jj) * sshn(ji,jj) + e12t(ji+1,jj) * sshn(ji+1,jj)
                sshn_u(ji,jj) = 0.5_wp * rtmp1 / e12u(ji,jj)
              ELSE IF(pt(ji,jj) <= 0) THEN
                sshn_u(ji,jj) = sshn(ji+1,jj)
              ELSE IF(pt(ji+1,jj) <= 0) THEN
                sshn_u(ji,jj) = sshn(ji,jj)
              END IF
            END DO
          END DO
! end kernel sshn_u updating.

! kernel: sshn_v updating
          ! acc loop collapse(2)
          DO jj = 0, jpj
            DO ji = 1, jpi
              IF(pt(ji,jj) + pt(ji,jj+1) <= 0)  CYCLE                              !jump over non-computational domain
              IF(pt(ji,jj) * pt(ji,jj+1) > 0) THEN
                rtmp1 = e12t(ji,jj) * sshn(ji,jj) + e12t(ji,jj+1) * sshn(ji,jj+1)
                sshn_v(ji,jj) = 0.5_wp * rtmp1 / e12v(ji,jj)
              ELSE IF(pt(ji,jj) <= 0) THEN
                sshn_v(ji,jj) = sshn(ji,jj+1)
              ELSE IF(pt(ji,jj+1) <= 0) THEN
                sshn_v(ji,jj) = sshn(ji,jj)
              END If
            END DO
          END DO
          !$acc end kernels
! end kernel sshn_v updating.

        END SUBROUTINE next

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE output
          INTEGER  :: ji, jj                          !temporary loop index
          REAL(wp) :: rtmp1, rtmp2, rtmp3, rtmp4      !real temporary variables

          ! output model results
          CHARACTER(len=5) :: fname

          return

          WRITE(fname, '(I5.5)') istp
          OPEN(1, file='go2d_'//fname//'.dat', STATUS='UNKNOWN')
          !OPEN(1, file='go2d_'//fname//'.csv', STATUS='UNKNOWN')
          REWIND(1)

          DO jj = 1, jpj
            DO ji = 1, jpi
              rtmp1 = 0.5_wp * (un(ji-1,jj) + un(ji,jj))
              rtmp2 = 0.5_wp * (vn(ji,jj-1) + vn(ji,jj))

              ! write "x-coord, y-coord, depth, ssh, u-velocity, v-velocity" to ASCII files

              !WRITE(1,'(2f20.3, 2f15.4, 2e18.3)')  &
              !WRITE(1,'(f20.3,'','',f20.3,'','',f15.4,'','',f15.4,'','',f18.3,'','',f18.3)') &
              write(1,'(6e16.7)') &
                   & xt(ji,jj), yt(ji,jj), ht(ji,jj), sshn(ji,jj),rtmp1, rtmp2
            END DO
            WRITE(1,*)
          END DO

          CLOSE(1)

        END SUBROUTINE output

!+++++++++++++++++++++++++++++++++++

        SUBROUTINE finalisation
          INTEGER :: ierr(11)

          DEALLOCATE(e1t, e2t, e1u, e2u, STAT=ierr(1))
          DEALLOCATE(e1f, e2f, e1v, e2v, STAT=ierr(2))
          DEALLOCATE(e12t, e12u, e12v, STAT=ierr(3))

          DEALLOCATE(gphiu, gphiv, gphif, STAT=ierr(4))

          DEALLOCATE(xt, yt, STAT=ierr(5))

          DEALLOCATE(ht, hu, hv, hf, STAT=ierr(6))

          DEALLOCATE(sshb, sshb_u, sshb_v, STAT=ierr(7))
          DEALLOCATE(sshn, sshn_u, sshn_v, STAT=ierr(8))
          DEALLOCATE(ssha, ssha_u, ssha_v, STAT=ierr(9))

          DEALLOCATE(un, vn, ua, va, STAT=ierr(10))

          DEALLOCATE(pt, STAT=ierr(11))

          !close opened files
          !send out some ending information
          IF(ANY(ierr /= 0, 1)) STOP "in SUBROUTINE finalisation: failed to deallocate arrays"

         call timer_report()

        END SUBROUTINE finalisation

!+++++++++++++++++++++++++++++++++++

    END PROGRAM nemolite2d


      SUBROUTINE SB02MU( DICO, HINV, UPLO, N, A, LDA, G, LDG, Q, LDQ, S,
     $                   LDS, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To construct the 2n-by-2n Hamiltonian or symplectic matrix S
C     associated to the linear-quadratic optimization problem, used to
C     solve the continuous- or discrete-time algebraic Riccati equation,
C     respectively.
C
C     For a continuous-time problem, S is defined by
C
C             (  A  -G )
C         S = (        ),                                       (1)
C             ( -Q  -A')
C
C     and for a discrete-time problem by
C
C                 -1       -1
C             (  A        A  *G     )
C         S = (   -1           -1   ),                          (2)
C             ( QA     A' + Q*A  *G )
C
C     or
C
C                       -T         -T
C             (  A + G*A  *Q   -G*A   )
C         S = (      -T            -T ),                        (3)
C             (    -A  *Q         A   )
C
C     where A, G, and Q are N-by-N matrices, with G and Q symmetric.
C     Matrix A must be nonsingular in the discrete-time case.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  Continuous-time system;
C             = 'D':  Discrete-time system.
C
C     HINV    CHARACTER*1
C             If DICO = 'D', specifies which of the matrices (2) or (3)
C             is constructed, as follows:
C             = 'D':  The matrix S in (2) is constructed;
C             = 'I':  The (inverse) matrix S in (3) is constructed.
C             HINV is not referenced if DICO = 'C'.
C
C     UPLO    CHARACTER*1
C             Specifies which triangle of the matrices G and Q is
C             stored, as follows:
C             = 'U':  Upper triangle is stored;
C             = 'L':  Lower triangle is stored.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A, G, and Q.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.
C             On exit, if DICO = 'D', and INFO = 0, the leading N-by-N
C                                                     -1
C             part of this array contains the matrix A  .
C             Otherwise, the array A is unchanged on exit.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     G       (input) DOUBLE PRECISION array, dimension (LDG,N)
C             The leading N-by-N upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             must contain the upper triangular part or lower triangular
C             part, respectively, of the symmetric matrix G. The stricly
C             lower triangular part (if UPLO = 'U') or stricly upper
C             triangular part (if UPLO = 'L') is not referenced.
C
C     LDG     INTEGER
C             The leading dimension of array G.  LDG >= MAX(1,N).
C
C     Q       (input) DOUBLE PRECISION array, dimension (LDQ,N)
C             The leading N-by-N upper triangular part (if UPLO = 'U')
C             or lower triangular part (if UPLO = 'L') of this array
C             must contain the upper triangular part or lower triangular
C             part, respectively, of the symmetric matrix Q. The stricly
C             lower triangular part (if UPLO = 'U') or stricly upper
C             triangular part (if UPLO = 'L') is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= MAX(1,N).
C
C     S       (output) DOUBLE PRECISION array, dimension (LDS,2*N)
C             If INFO = 0, the leading 2N-by-2N part of this array
C             contains the Hamiltonian or symplectic matrix of the
C             problem.
C
C     LDS     INTEGER
C             The leading dimension of array S.  LDS >= MAX(1,2*N).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (2*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK; if DICO = 'D', DWORK(2) returns the reciprocal
C             condition number of the given matrix  A.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= 1          if DICO = 'C';
C             LDWORK >= MAX(2,4*N) if DICO = 'D'.
C             For optimum performance LDWORK should be larger, if
C             DICO = 'D'.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = i:  if the leading i-by-i (1 <= i <= N) upper triangular
C                   submatrix of A is singular in discrete-time case;
C             = N+1:  if matrix A is numerically singular in discrete-
C                   time case.
C
C     METHOD
C
C     For a continuous-time problem, the 2n-by-2n Hamiltonian matrix (1)
C     is constructed.
C     For a discrete-time problem, the 2n-by-2n symplectic matrix (2) or
C     (3) - the inverse of the matrix in (2) - is constructed.
C
C     NUMERICAL ASPECTS
C
C     The discrete-time case needs the inverse of the matrix A, hence
C     the routine should not be used when A is ill-conditioned.
C                               3
C     The algorithm requires 0(n ) floating point operations in the
C     discrete-time case.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Aug. 1997.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Feb. 2004,
C     Aug. 2011.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, closed loop system, continuous-time
C     system, discrete-time system, optimal regulator, Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, HINV, UPLO
      INTEGER           INFO, LDA, LDG, LDQ, LDS, LDWORK, N
C     .. Array Arguments ..
      INTEGER           IWORK(*)
      DOUBLE PRECISION  A(LDA,*), DWORK(*), G(LDG,*), Q(LDQ,*),
     $                  S(LDS,*)
C     .. Local Scalars ..
      LOGICAL           DISCR, LHINV, LQUERY, LUPLO
      INTEGER           I, J, MAXWRK, MINWRK, N2, NJ, NP1
      DOUBLE PRECISION  ANORM, RCOND
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE
      EXTERNAL          DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGECON, DGEMM, DGETRF, DGETRI, DGETRS,
     $                  DLACPY, DSWAP, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX
C     .. Executable Statements ..
C
      INFO = 0
      N2 = N + N
      DISCR = LSAME( DICO, 'D' )
      LUPLO = LSAME( UPLO, 'U' )
      IF( DISCR ) THEN
         LHINV = LSAME( HINV, 'D' )
      ELSE
         LHINV = .FALSE.
      END IF
C
C     Test the input scalar arguments.
C
      IF( .NOT.DISCR .AND. .NOT.LSAME( DICO, 'C' ) ) THEN
         INFO = -1
      ELSE IF( DISCR ) THEN
         IF( .NOT.LHINV .AND. .NOT.LSAME( HINV, 'I' ) )
     $      INFO = -2
      END IF
      IF( .NOT.LUPLO .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDG.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDS.LT.MAX( 1, N2 ) ) THEN
         INFO = -12
      ELSE
         MINWRK = MAX( 2, 4*N )
         LQUERY = LDWORK.EQ.-1
         IF( ( LDWORK.LT.1 .OR. ( DISCR .AND. LDWORK.LT.MINWRK ) ) .AND.
     $       .NOT.LQUERY ) THEN
            INFO = -15
         ELSE IF( DISCR ) THEN
C
C           Compute workspace.
C           (Note: Comments in the code beginning "Workspace:" describe
C           the minimal amount of workspace needed at that point in the
C           code, as well as the preferred amount for good performance.
C           NB refers to the optimal block size for the immediately
C           following subroutine, as returned by ILAENV.)
C
            CALL DGETRI( N, A, LDA, IWORK, DWORK, -1, INFO )
            MAXWRK = MAX( MINWRK, INT( DWORK(1) ) )
         ELSE
            MAXWRK = 1
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'SB02MU', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 ) THEN
         DWORK(1) = ONE
         IF ( DISCR ) DWORK(2) = ONE
         RETURN
      END IF
C
C     The code tries to exploit data locality as much as possible.
C
      IF ( .NOT.LHINV ) THEN
         CALL DLACPY( 'Full', N, N, A, LDA, S, LDS )
C
C        Construct Hamiltonian matrix in the continuous-time case, or
C        prepare symplectic matrix in (3) in the discrete-time case:
C
C        Construct full Q in S(N+1:2*N,1:N) and change the sign, and
C        construct full G in S(1:N,N+1:2*N) and change the sign.
C
         DO 200 J = 1, N
            NJ = N + J
            IF ( LUPLO ) THEN
C
               DO 20 I = 1, J
                  S(N+I,J) = -Q(I,J)
   20          CONTINUE
C
               DO 40 I = J + 1, N
                  S(N+I,J) = -Q(J,I)
   40          CONTINUE
C
               DO 60 I = 1, J
                  S(I,NJ) = -G(I,J)
   60          CONTINUE
C
               DO 80 I = J + 1, N
                  S(I,NJ) = -G(J,I)
   80          CONTINUE
C
            ELSE
C
               DO 100 I = 1, J - 1
                  S(N+I,J) = -Q(J,I)
  100          CONTINUE
C
               DO 120 I = J, N
                  S(N+I,J) = -Q(I,J)
  120          CONTINUE
C
               DO 140 I = 1, J - 1
                  S(I,NJ) = -G(J,I)
  140          CONTINUE
C
               DO 180 I = J, N
                  S(I,NJ) = -G(I,J)
  180          CONTINUE
C
            END IF
  200    CONTINUE
C
         IF ( .NOT.DISCR ) THEN
C
            DO 240 J = 1, N
               NJ = N + J
C
               DO 220 I = 1, N
                  S(N+I,NJ) = -A(J,I)
  220          CONTINUE
C
  240       CONTINUE
C
            DWORK(1) = ONE
         END IF
      END IF
C
      IF ( DISCR ) THEN
C
C        Construct the symplectic matrix (2) or (3) in the discrete-time
C        case.
C
         NP1 = N + 1
C
         IF ( LHINV ) THEN
C
C           Put  A'  in  S(N+1:2*N,N+1:2*N).
C
            DO 260 I = 1, N
               CALL DCOPY( N, A(I, 1), LDA, S(NP1,N+I), 1 )
  260       CONTINUE
C
         END IF
C
C        Compute the norm of the matrix A.
C
         ANORM = DLANGE( '1-norm', N, N, A, LDA, DWORK )
C
C        Compute the LU factorization of A.
C
         CALL DGETRF( N, N, A, LDA, IWORK, INFO )
C
C        Return if INFO is non-zero.
C
         IF( INFO.GT.0 ) THEN
            DWORK(2) = ZERO
            RETURN
         END IF
C
C        Compute the reciprocal of the condition number of A.
C        Workspace: need 4*N.
C
         CALL DGECON( '1-norm', N, A, LDA, ANORM, RCOND, DWORK,
     $                IWORK(NP1), INFO )
C
C        Return if the matrix is singular to working precision.
C
         IF( RCOND.LT.DLAMCH( 'Epsilon' ) ) THEN
            INFO = N + 1
            DWORK(2) = RCOND
            RETURN
         END IF
C
         IF ( LHINV ) THEN
C
C           Compute S in (2).
C
C           Construct full Q in S(N+1:2*N,1:N).
C
            IF ( LUPLO ) THEN
               DO 270 J = 1, N - 1
                  CALL DCOPY( J, Q(1,J), 1, S(NP1,J), 1 )
                  CALL DCOPY( N-J, Q(J,J+1), LDQ, S(NP1+J,J), 1 )
  270          CONTINUE
               CALL DCOPY( N, Q(1,N), 1, S(NP1,N), 1 )
            ELSE
               CALL DCOPY( N, Q(1,1), 1, S(NP1,1), 1 )
               DO 280 J = 2, N
                  CALL DCOPY( J-1, Q(J,1), LDQ, S(NP1,J), 1 )
                  CALL DCOPY( N-J+1, Q(J,J), 1, S(N+J,J), 1 )
  280          CONTINUE
            END IF
C
C           Compute the solution matrix  X  of the system  X*A = Q  by
C                                                                    -1
C           solving  A'*X' = Q and transposing the result to get  Q*A  .
C
            CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1),
     $                   LDS, INFO )
C
            DO 300 J = 1, N - 1
               CALL DSWAP( N-J, S(NP1+J,J), 1, S(N+J,J+1), LDS )
  300       CONTINUE
C
C           Construct full G in S(1:N,N+1:2*N).
C
            IF ( LUPLO ) THEN
               DO 310 J = 1, N - 1
                  CALL DCOPY( J, G(1,J), 1, S(1,N+J), 1 )
                  CALL DCOPY( N-J, G(J,J+1), LDG, S(J+1,N+J), 1 )
  310          CONTINUE
               CALL DCOPY( N, G(1,N), 1, S(1,N2), 1 )
            ELSE
               CALL DCOPY( N, G(1,1), 1, S(1,NP1), 1 )
               DO 320 J = 2, N
                  CALL DCOPY( J-1, G(J,1), LDG, S(1,N+J), 1 )
                  CALL DCOPY( N-J+1, G(J,J), 1, S(J,N+J), 1 )
  320          CONTINUE
            END IF
C                            -1
C           Compute  A' + Q*A  *G  in  S(N+1:2N,N+1:2N).
C
            CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $                  S(NP1,1), LDS, S(1,NP1), LDS, ONE, S(NP1,NP1),
     $                  LDS )
C
C           Compute the solution matrix  Y  of the system  A*Y = G.
C
            CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1),
     $                   LDS, INFO )
C
C           Compute the inverse of  A  in situ.
C           Workspace: need N;  prefer N*NB.
C
            CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO )
C                  -1
C           Copy  A    in  S(1:N,1:N).
C
            CALL DLACPY( 'Full', N, N, A, LDA, S, LDS )
C
         ELSE
C
C           Compute S in (3) using the already prepared part.
C
C           Compute the solution matrix  X'  of the system  A*X' = -G
C                                                       -T
C           and transpose the result to obtain  X = -G*A  .
C
            CALL DGETRS( 'No transpose', N, N, A, LDA, IWORK, S(1,NP1),
     $                   LDS, INFO )
C
            DO 340 J = 1, N - 1
               CALL DSWAP( N-J, S(J+1,N+J), 1, S(J,NP1+J), LDS )
  340       CONTINUE
C                           -T
C           Compute  A + G*A  *Q  in  S(1:N,1:N).
C
            CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE,
     $                  S(1,NP1), LDS, S(NP1, 1), LDS, ONE, S, LDS )
C
C           Compute the solution matrix  Y  of the system  A'*Y = -Q.
C
            CALL DGETRS( 'Transpose', N, N, A, LDA, IWORK, S(NP1,1),
     $                   LDS, INFO )
C
C           Compute the inverse of  A  in situ.
C           Workspace: need N;  prefer N*NB.
C
            CALL DGETRI( N, A, LDA, IWORK, DWORK, LDWORK, INFO )
C                  -T
C           Copy  A    in  S(N+1:2N,N+1:2N).
C
            DO 360 J = 1, N
               CALL DCOPY( N, A(J,1), LDA, S(NP1,N+J), 1 )
  360       CONTINUE
C
         END IF
         DWORK(1) = MAXWRK
         DWORK(2) = RCOND
      END IF
C
C *** Last line of SB02MU ***
      RETURN
      END


!->Module LIB_BGEOM. Rafa Palacios. Last Update 6Aug2008.
!
!->Description.-
!
!    Subroutines for computing geometric magnitudes in beam elements.
!
!->Subroutines.-
!
!    -bgeom_elemlength  : Compute length of the element.
!    -bgeom_elemcurv2   : Compute curvature vector of a 2-noded element.
!    -bgeom_elemframe   : Compute element frame orientation.
!    -bgeom_nodeframe   : Compute frame orientation for nodes in an element.
!    -bgeom_strain2disp : Integrate strains along reference line.
!
!->Remarks.-
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module lib_bgeom
 implicit none

! (This module does not contain Public Variables).

!-> Private variables.
  real(8),private,parameter,dimension(3,3):: Unit= &         ! Unit matrix.
&         reshape((/1.d0,0.d0,0.d0,0.d0,1.d0,0.d0,0.d0,0.d0,1.d0/),(/3,3/))

 contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-> Subroutine BGEOM_ELEMLENGTH
!
!-> Description:
!
!    Compute length of an element using Gaussian integration.
!
!-> Remarks.-
!
!   1) The element can have an arbitrary number of nodes. Isoparametric
!      interpolation is used.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine bgeom_elemlength (NumGauss,NumNodesElem,Coords,Arclength)
  use lib_fem

! I/O Variables.
  integer,intent(in) :: NumGauss          ! Number of Gauss integration points.
  integer,intent(in) :: NumNodesElem      ! Number of nodes in the element.
  real(8),intent(in) :: Coords    (:,:)   ! Coordinates of the grid points.
  real(8),intent(out):: ArcLength         ! Element total arclength.

! Local variables.
  integer :: i                     ! Counters.
  integer :: iGauss                ! Counter on the Gaussian points.
 real(8) :: dXgauss(3)            ! Coordinate at the Gauss point.
  real(8),allocatable :: ShapeFun(:)    ! Shape functions for a gauss CoordGauss.
  real(8),allocatable :: ShapeDer(:)    ! Derivatives of ShapeFun in a gauss CoordGauss.
  real(8),allocatable :: CoordGauss (:) ! Coords of Gauss points.
  real(8),allocatable :: WeightGauss(:) ! Coords of Gauss points.

! Initialize.
  Arclength=0.d0
  allocate (CoordGauss (NumGauss))
  allocate (WeightGauss(NumGauss))
  allocate (ShapeFun   (NumNodesElem))
  allocate (ShapeDer   (NumNodesElem))

! Define Gauss points and loop on them.
  call fem_1d_gauss_val (NumGauss,CoordGauss,WeightGauss)
  !                          in      out       out

  do iGauss=1,NumGauss

! Obtain the shape functions and their derivatives.
    call fem_1d_shapefun (NumNodesElem,CoordGauss(iGauss),ShapeFun,ShapeDer)

! Global coordinates and their derivatives at the gauss points.
    do i=1,3
      dXgauss(i)= dot_product (ShapeDer(1:NumNodesElem),Coords(1:NumNodesElem,i))
    end do

! Jacobian of the arclength function at the Gauss point.
    ArcLength=ArcLength+WeightGauss(iGauss)*(sqrt(dot_product(dXgauss,dXgauss)))

  end do

  deallocate (CoordGauss,WeightGauss)
  deallocate (ShapeFun,ShapeDer)
  return
 end subroutine bgeom_elemlength

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-> Subroutine BGEOM_ELEMCURV2
!
!-> Description:
!
!    Compute curvature at the center of a 2-noded beam element for given
!    cartesian rotation vector at its nodes.
!
!-> Remarks.-
!
!  1) This is vector kb in the undeformed frame, b.
!
!  2) Element goes from node A to node B.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine bgeom_elemcurv2 (PosGrids,PsiGrids,kb)
  use lib_fem
  use lib_rotvect

! I/O Variables.
  real(8),intent(in) :: PosGrids (:,:) ! Position vector at nodes.
  real(8),intent(in) :: PsiGrids (:,:) ! CRV at nodes
  real(8),intent(out):: kb     (3)     ! Curvature of the element.

! Local variables.
  real(8) :: dx(3)                     ! Derivatives at each point.
  real(8) :: Psi0(3),dPsi0(3)          ! Interpolated rotation vector and its derivative.
  real(8) :: Jacobian                  ! ds/deta.
  integer :: NumNodesElem              ! Number of nodes in the element.
  real(8),allocatable :: ShapeFun(:)   ! Shape functions for a gauss CoordGauss.
  real(8),allocatable :: ShapeDer(:)   ! Derivatives of ShapeFun in a gauss CoordGauss.

! Initialize
  NumNodesElem=2
  allocate (ShapeFun(NumNodesElem)); ShapeFun=0.d0
  allocate (ShapeDer(NumNodesElem)); ShapeDer=0.d0

! Obtain the shape functions derivatives at the element center point.
  call fem_1d_shapefun (NumNodesElem,0.d0,ShapeFun,ShapeDer)

! Compute Jacobian and the differential operator in physical coordinates.
  dx= matmul(ShapeDer,PosGrids(1:NumNodesElem,:))
  Jacobian=dsqrt(dot_product(dx,dx))
  ShapeDer=ShapeDer/Jacobian

! Compute value of the rotation vector and its derivative at the center point.
  Psi0 = matmul(ShapeFun,PsiGrids(1:NumNodesElem,:))
  dPsi0= matmul(ShapeDer,PsiGrids(1:NumNodesElem,:))

  kb= matmul(rotvect_psi2rot (Psi0),dPsi0)

  deallocate (ShapeFun,ShapeDer)
  return
 end subroutine bgeom_elemcurv2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-> Subroutine BGEOM_ELEMFRAME
!
!-> Description:
!
!    Compute element frame as defined by MSC conventions.
!
!-> Remarks.-
!
!  1) Element frame is the 'a' frame in the co-rotational approach.
!
!  2) X axis is defined by the two end nodes of the elements.  The X-Z plane
!     is orthogonal to the given V vector.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine bgeom_elemframe (r,V,Psi,Delta)
  use lib_rot
  use lib_rotvect

! I/O Variables.
  real(8),intent(in) :: r(2,3)         ! Position vector of initial and final node.
  real(8),intent(in) :: V(3)           ! Cross-sectional orientation vector.
  real(8),intent(out):: Psi(3)         ! CRV of the element orientation.
  real(8),intent(in) :: Delta          ! Minimum angle for two unit vectors to be parallel.

! Local variables.
  real(8)::  Cag (3,3)                 ! Coordinate transformation matrix from global to element frame.
  real(8)::  d(3)                      ! Direction of base vector.

! X-axis.
  d=r(2,:)-r(1,:)
  Cag(1,:)= d/sqrt(dot_product(d,d))

! Z-axis.
  d=rot_cross(Cag(1,:),V)

  if (sqrt(dot_product(d,d)).le.Delta) &
&    STOP 'Element Vector V is not orthogonal to reference line (51105)'

  Cag(3,:)= d/sqrt(dot_product(d,d))

! Y-axis.
  Cag(2,:)= rot_cross(Cag(3,:),Cag(1,:))

! Convert to rotation vector with respect to the reference (global) frame.
  Psi= rotvect_mat2psi(Cag)

  return
 end subroutine bgeom_elemframe

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-> Subroutine BGEOM_NODEFRAME
!
!-> Description:
!
!    For a given node, compute undeformed coordinate system ('b' frame) at
!    each of the element nodes.
!
!-> Remarks.-
!
!  1) V is only used for collinear points in an element. This is defined
!     by the convergence parameter (Delta).
!
! -> Reference:
! [1] par.4.4 "Three Noded Geometrically Nonlinear Composite Beam", Palacios R. (2009)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine bgeom_nodeframe (NumNodesElem,Coords,Phi,V,Psi,Delta)
  use lib_fem
  use lib_rot
  use lib_rotvect

! I/O Variables.
  integer,intent(in) :: NumNodesElem   ! Number of nodes in the element.
  real(8),intent(in) :: Coords  (:,:)  ! Coordinates of the grid points.
  real(8),intent(in) :: Phi     (:)    ! Pretwist at grid points.
  real(8),intent(in) :: V       (:)    ! Element cross-sectional orientation.
  real(8),intent(out):: Psi     (:,:)  ! CRV at each node.
  real(8),intent(in) :: Delta          ! Minimum angle for two unit vectors to be parallel.

! Local variables.
  real(8) :: AuxV(3)                   ! Auxiliary vector.
  real(8) :: Cgb(3,3)                  ! Coordinate transformation matrix from global to local.
  integer :: iNode                     ! Counter on the nodes in the element.
  integer :: j                         ! Counters.
  real(8) :: dx(3)                     ! Derivatives of the position vector at each point.
  real(8) :: e_t(3),e_n(3),e_b(3)      ! Tangent, normal, and binormal vectors.
  real(8) :: Phi0                      ! Defines direction of zero pretwist.
  real(8) :: v12(3),v13(3),v23(3)      ! Auxiliary vectors.

  real(8),allocatable:: Eta     (:)    ! Nodal position in the 1-D nondimensional coordinate.
  real(8),allocatable:: ShapeFun(:)    ! Shape functions for a gauss CoordGauss.
  real(8),allocatable:: ShapeDer(:)    ! Derivatives of ShapeFun in a gauss CoordGauss.

! Initialize
  allocate (Eta     (NumNodesElem)); Eta     = 0.d0
  allocate (ShapeFun(NumNodesElem)); ShapeFun= 0.d0
  allocate (ShapeDer(NumNodesElem)); ShapeFun= 0.d0

  v12=Coords(2,:)-Coords(1,:)
  v12=v12/sqrt(dot_product(v12,v12))

  select case (NumNodesElem)
  case (3)
! If there are three nodes, compute the vector in the normal plane.
    Eta=(/-1.d0,1.d0,0.d0/)
    v13=Coords(3,:)-Coords(1,:)
    v13=v13/sqrt(dot_product(v13,v13))
    v23=rot_cross(v13,v12)

  case (2)
    Eta=(/-1.d0,1.d0/)
    v23=0.d0

  case default
    STOP 'Wrong number of nodes in the element (51248)'
  end select

! Loop through the element nodes.
  Phi0 = 0.0
  do iNode=1,NumNodesElem

  ! Obtain the shape functions derivatives (at the nodes)
  ! sm: this step does only depend on the number of nodes and returns:
  ! ----------  case(3) ----------------- ! ----------  case(2) ---------------
  !  1.0   0.0    0.0   ShapeFun iNode=-1 !  1.0   0.0        ShapeFun iNode=-1
  !  0.0   1.0    0.0   ShapeFun iNode= 1 !  0.0   1.0        ShapeFun iNode= 1
  !  0.0   0.0    1.0   ShapeFun iNode= 0 !
  ! -1.5  -0.5    2.0   ShapeDer iNode=-1 ! -0.5   0.5        ShapeDer iNode=-1
  !  0.5   1.5   -2.0   ShapeDer iNode= 1 ! -0.5   0.5        ShapeDer iNode= 1
  ! -0.5   0.5    0.0   ShapeDer iNode= 0 !
  ! ----------  case(3) ----------------- ! ----------  case(2) ---------------
    call fem_1d_shapefun (NumNodesElem,Eta(iNode),ShapeFun,ShapeDer)

  ! Compute Jacobian.
  ! Following ref.[1] notation, this will be
  ! dx_j = dr_j/dxi evaluated at xi_iNode
    do j=1,3
      dx(j)= dot_product (ShapeDer,Coords(1:NumNodesElem,j))
    end do

  ! Compute Frenet FoR unit vectors e_t, e_b, e_n
  ! Tangent vector.
    e_t=dx/sqrt(dot_product(dx,dx))

  ! Binormal vector for collinear and non-collinear cases.
    if (sqrt(dot_product(v23,v23)).le.Delta) then ! this is always true for linear beam
      AuxV=rot_cross(v12,V)
      e_b=AuxV/dsqrt(dot_product(AuxV,AuxV))
    else
      e_b=v23/dsqrt(dot_product(v23,v23))
    end if

  ! Normal vector (normalization included to avoid numerical problems).
    e_n=rot_cross(e_b,e_t)
    e_n=e_n/dsqrt(dot_product(e_n,e_n))

  ! Grid A is used to establish the reference for the pretwist angle, which is defined
  ! as the angle that vector e_n needs to be rotated around e_t so that it lies in the
  ! element X-Y plane.
    if (iNode.eq.1) then
      AuxV=rot_cross(rot_cross(v12,V),e_t)
      AuxV=AuxV/sqrt(dot_product(AuxV,AuxV))
      if (sqrt(dot_product(AuxV,AuxV)).gt.Delta) then
        Phi0= sign(acos(max(-1.d0,min(dot_product(e_n,AuxV),1.d0))), &
  &                dot_product(e_t,rot_cross(v12,V)))
      else
        AuxV=rot_cross(v12,rot_cross(v12,V))
        AuxV=AuxV/sqrt(dot_product(AuxV,AuxV))
        Phi0= sign(acos(max(-1.d0,min(dot_product(e_n,AuxV),1.d0))), &
  &                dot_product(e_n,V))
      end if
    end if

  ! Rotate vectors with the pretwist angle.
    Cgb(1,:)= e_t
    Cgb(2,:)= e_n*cos(Phi0+Phi(iNode))+e_b*sin(Phi0+Phi(iNode))
    Cgb(3,:)=-e_n*sin(Phi0+Phi(iNode))+e_b*cos(Phi0+Phi(iNode))

  ! Compute the cartesian rotation vector that defines
    Psi(iNode,:)= rotvect_mat2psi(Cgb)
  end do

  return
 end subroutine bgeom_nodeframe

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!-> Subroutine BGEOM_STRAIN2DISP
!
!-> Description:
!
!    Integrate strain/curvature along a continuous reference line and
!    compute the nodal values of the position and rotation vectors.
!
!-> Remarks.-
!
!  1) The strain is assumed constant within each element.
!
!  2) This routine is only valid for 2-noded elements along a single line.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 subroutine bgeom_strain2disp (NumElems,PsiIni,Lengths,Gamma,Curvature,PosFin,PsiFin)
  use lib_fem
  use lib_rotvect

! I/O Variables.
  integer,intent(in) :: NumElems         ! Number of elements in the model.
  real(8),intent(in) :: PsiIni  (:,:,:)  ! Undeformed orientation vector (CRV).
  real(8),intent(in) :: Lengths (:)      ! Element lengths.
  real(8),intent(in) :: Gamma   (:,:)    ! Extensional strain within each element.
  real(8),intent(in) :: Curvature (:,:)  ! Total curvature in the element (KB).
  real(8),intent(out):: PosFin  (:,:)    ! Position vector at end nodes.
  real(8),intent(out):: PsiFin  (:,:,:)  ! CRV at the nodes.

! Local variables.
  integer:: iElem              ! Counter on the finite elements.
  real(8):: C_aB(3,3)          ! Coordinate transformation matrix at current node.
  real(8):: C_aB1(3,3)         ! Trafo matrix at end of previous element.
  real(8):: C_aB2(3,3)         ! Trafo matrix at beginning of current element.
  real(8):: DeltaPsi(3)        ! KB*DeltaS.
  real(8):: H0(3,3),H1(3,3)    ! Element rotation operators.
  real(8):: Ra(3)              ! Position vector at current node.

! Initialize the kinematic chain.
  C_aB= Unit
  Ra = 0.d0

! Loop in all elements in the model.
  do iElem=1,NumElems

! Compute orientation change at the first node of the element
! from the previous element.
    if (iElem.gt.1) then
      C_aB1= rotvect_psi2mat(-PsiIni(iElem-1,2,:))
    else
      C_aB1= rotvect_psi2mat(-PsiIni(iElem,1,:))
    end if
    C_aB2= rotvect_psi2mat(-PsiIni(iElem,1,:))
    C_aB=matmul(C_aB,matmul(transpose(C_aB1),C_aB2))
    PsiFin(iElem,1,:)= rotvect_mat2psi(transpose(C_aB))

! Integrate displacements.
    DeltaPsi= Lengths(iElem) * Curvature(iElem,:)
    H1= Lengths(iElem)*rotvect_psi2intmat(-DeltaPsi)
    Ra= Ra + matmul(C_aB,matmul(H1,Unit(1:3,1)+Gamma(iElem,:)))

! Integrate rotation.
    H0  = rotvect_psi2mat(-DeltaPsi)
    C_aB= matmul(C_aB,H0)

! Store values.
    PosFin(iElem,:)  = Ra
    PsiFin(iElem,2,:)= rotvect_mat2psi(transpose(C_aB))
  end do

 end subroutine bgeom_strain2disp

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
end module lib_bgeom


SUBROUTINE dple(rowk, n, b, c, ierr)
! Code from the Naval Surface Warfare Center Mathematics Library.
! Solves A.c = b where the n x n matrix is not stored but read in,
! one row at a time.
! The amount of storage required is slightly over (n/2)^2 for large n,
! or just over a quarter of that which would be required to store A.

! The user must provide the routine ROWK to read in row K of the matrix.
! The rows are read sequentially; each row is read once only.

! N.B. Arguments D & IP have been removed.

! Code converted using TO_F90 by Alan Miller
! Date: 2000-10-20  Time: 22:49:06

!     ******************************************************************
!     SOLUTION OF LINEAR EQUATIONS WITH REDUCED STORAGE
!     ******************************************************************

! The partial pivot Henderson-Wassyng algorithm is used.
! Reference:
! Wassyng, A. "Solving Ax = b: A method with reduced storage requirements",
! SIAM J. Numerical Analysis, vol.19 (1982), pp.197-204.

IMPLICIT NONE
INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

INTEGER, INTENT(IN)     :: n
REAL (dp), INTENT(IN)   :: b(:)
REAL (dp), INTENT(OUT)  :: c(:)
INTEGER, INTENT(OUT)    :: ierr

INTERFACE
  SUBROUTINE rowk(n, k, row)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
    INTEGER, INTENT(IN)     :: n, k
    REAL (dp), INTENT(OUT)  :: row(:)
  END SUBROUTINE rowk
END INTERFACE

! Local variables

REAL (dp)  :: bk, cj, ck, c1, dkj
INTEGER    :: i, iflag, ij, ijold, ik, ip(n-1), j, k, kjold, km1, kp1,  &
              last, lastm1, lcol, lcolp1, m, MAX, mjold, nm1, np1
REAL (dp), PARAMETER    :: zero = 0.0_dp
REAL (dp), ALLOCATABLE  :: d(:)

!     SET THE NECESSARY CONSTANTS

ierr = 0
np1 = n + 1
MAX = n * n / 4 + n + 3
ALLOCATE( d(MAX) )
k = 1
iflag = -1

!     GET THE FIRST COLUMN OF THE TRANSPOSED SYSTEM

CALL rowk(n, 1, c)
bk = b(1)

IF (n <= 1) THEN
  IF (c(1) == zero) GO TO 130
  c(1) = bk / c(1)
  RETURN
END IF

!     FIND THE PIVOT FOR COLUMN 1

m = 1
DO  i = 2, n
  IF (ABS(c(m)) < ABS(c(i))) m = i
END DO

ip(1) = m
c1 = c(m)
c(m) = c(1)
c(1) = c1
IF (c(1) /= zero) THEN

!     FIND THE FIRST ELEMENTARY MATRIX AND STORE IT IN D

  DO  i = 2, n
    d(i-1) = -c(i) / c(1)
  END DO
  d(n) = bk / c(1)

!     K LOOP - EACH K FOR A NEW COLUMN OF THE TRANSPOSED SYSTEM

  DO  k = 2, n
    kp1 = k + 1
    km1 = k - 1

!       GET COLUMN K

    CALL rowk(n, k, c)
    DO  j = 1, km1
      m = ip(j)
      cj = c(j)
      c(j) = c(m)
      c(m) = cj
    END DO
    bk = b(k)

    iflag = -iflag
    lcol = np1 - k
    lcolp1 = lcol + 1
    lastm1 = 1
    last = MAX - n + k
    IF (k /= 2) THEN

      lastm1 = MAX - n + km1
      IF (iflag < 0) last = last - n + k - 2
      IF (iflag > 0) lastm1 = lastm1 - n + k - 3
    END IF

!     J LOOP - EFFECT OF COLUMNS 1 TO K-1 OF L-INVERSE

    DO  j = 1, km1
      cj = c(j)
      ij = (j-1) * lcolp1
      IF (j == km1) ij = lastm1 - 1

!     I LOOP - EFFECT OF L-INVERSE ON ROWS K TO N+1

      DO  i = k, n
        ij = ij + 1
        c(i) = c(i) + d(ij) * cj
      END DO
      bk = bk - d(ij+1) * cj
    END DO

!       K=N CASE

    m = k
    IF (k >= n) THEN
      IF (c(k) == zero) GO TO 130
      d(last) = bk / c(k)
    ELSE

!     FIND THE PIVOT

      DO  i = kp1, n
        IF (ABS(c(m)) < ABS(c(i))) m = i
      END DO

      ip(k) = m
      ck = c(m)
      c(m) = c(k)
      c(k) = ck
      IF (c(k) == zero) GO TO 130

!     FIND THE K-TH ELEMENTARY MATRIX

      ik = last
      DO  i = kp1, n
        d(ik) = -c(i) / c(k)
        ik = ik + 1
      END DO
      d(ik) = bk / c(k)
    END IF

!     FORM THE PRODUCT OF THE ELEMENTARY MATRICES

    DO  j = 1, km1
      kjold = j * lcolp1 + k - np1
      mjold = kjold + m - k
      ij = (j-1) * lcol
      ijold = ij + j
      IF (j == km1) THEN

        kjold = lastm1
        mjold = lastm1 + m - k
        ijold = lastm1
      END IF

      ik = last - 1
      dkj = d(mjold)
      d(mjold) = d(kjold)
      DO  i = kp1, np1
        ij = ij + 1
        ijold = ijold + 1
        ik = ik + 1
        d(ij) = d(ijold) + d(ik) * dkj
      END DO
    END DO
  END DO

  last = MAX
  IF (iflag < 0) last = MAX - 2
  d(n) = d(last)

!     INSERT THE SOLUTION IN C

  c(1:n) = d(1:n)

  nm1 = n - 1
  DO  i = 1, nm1
    k = n - i
    m = ip(k)
    ck = c(k)
    c(k) = c(m)
    c(m) = ck
  END DO
  RETURN
END IF

!     THE SYSTEM IS SINGULAR

130 ierr = k
RETURN
END SUBROUTINE dple

SUBROUTINE rowk(n, k, row)
IMPLICIT NONE
INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
INTEGER, INTENT(IN)     :: n, k
REAL (dp), INTENT(OUT)  :: row(:)

READ(UNIT=9) row(1:n)

RETURN
END SUBROUTINE rowk

PROGRAM test_big_solve
IMPLICIT NONE

INTERFACE
  SUBROUTINE dple(rowk, n, b, c, ierr)
    IMPLICIT NONE
    INTEGER, PARAMETER  :: dp = SELECTED_REAL_KIND(12, 60)

    INTEGER, INTENT(IN)     :: n
    REAL (dp), INTENT(IN)   :: b(:)
    REAL (dp), INTENT(OUT)  :: c(:)
    INTEGER, INTENT(OUT)    :: ierr

    INTERFACE
      SUBROUTINE rowk(n, k, row)
        IMPLICIT NONE
        INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
        INTEGER, INTENT(IN)     :: n, k
        REAL (dp), INTENT(OUT)  :: row(:)
      END SUBROUTINE rowk
    END INTERFACE
  END SUBROUTINE dple

  SUBROUTINE rowk(n, k, row)
    IMPLICIT NONE
    INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
    INTEGER, INTENT(IN)     :: n, k
    REAL (dp), INTENT(OUT)  :: row(:)
  END SUBROUTINE rowk
END INTERFACE

INTEGER, PARAMETER      :: dp = SELECTED_REAL_KIND(12, 60)
INTEGER                 :: i, ierr, n, row
REAL (dp), ALLOCATABLE  :: b(:), c(:)
REAL (dp)               :: errmax, total
REAL                    :: finish, start

WRITE(*, '(a)', ADVANCE='NO') ' Enter no. of rows (n): '
READ(*, *) n
ALLOCATE( b(n), c(n) )

! The solution will be:
! c = 1, 2, 3, ..., n

! Generate a matrix of random numbers which is written to a scratch file

OPEN(UNIT=9, STATUS='SCRATCH', FORM='UNFORMATTED')
DO row = 1, n
  CALL RANDOM_NUMBER( c )
  total = 0
  DO i = 1, n
    total = total + i * c(i)
  END DO
  b(row) = total
  WRITE(9) c
END DO
REWIND (9)

CALL CPU_TIME(start)
CALL dple(rowk, n, b, c, ierr)
CALL CPU_TIME(finish)

WRITE(*, '(a, F9.2, a)') ' Time taken = ', finish-start, 'sec.'
errmax = 0.0_dp
DO i = 1, n
  errmax = MAX( errmax, ABS(c(i)-i) )
END DO
WRITE(*, '(a, g12.3)') ' Max. error = ', errmax

STOP

END PROGRAM test_big_solve