c     ****************************************************************
c     *                                                              *
c     *                      subroutine dptstf                       *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 07/29/2017 rhd             *
c     *                                                              *
c     *     this subroutine creates a separate copy of all element   *
c     *     data necessary for the tangent stiffness computation of  *
c     *     each element in a block of similar, non-conflicting      *
c     *     elements.                                                *
c     *                                                              *
c     ****************************************************************
c
c
      subroutine dptstf( span, bedst, bcdst, belinc, felem, ngp,
     &                   nnode, ndof, geonl, totdof, mat_type,
     &                   trn_e_flags,
     &                   trn_e_block,
     &                   ce,  ce_0,
     &                   trne,
     &                   trnmte,
     &                   ue,
     &                   due,
     &                   local_cp,
     &                   local_icp, trn, elem_type, surface,
     &                   cohesive_elem )
      use global_data ! old common.main
      use elem_extinct_data, only : dam_state
      use damage_data, only : dam_ptr, growth_by_kill

      implicit integer (a-z)
      dimension bedst(totdof,*), bcdst(totdof,*), belinc(nnode,*),
     &          local_cp(*),
     &          local_icp(mxutsz,*)
      logical   trn_e_flags(*), trn_e_block, trne(mxvl,*),
     &          geonl, trn(*), cohesive_elem,
     &          middle_surface
      double precision
     & ce(mxvl,*), trnmte(mxvl,mxedof,*), ue(mxvl,*), due(mxvl,*),
     & ce_orig(mxvl,mxecor), djcoh(mxvl), zero, ce_0(mxvl,mxecor)
      data zero / 0.0 /
c
c           transformation matrices are used to define a "local"
c           coordinate systen for imposition of constraints, e.g.,
c           skewed. if transformations are present, they are used
c           to rotate the computed element stiffness terms for those
c           nodes with constraint coordinate systems. also, for
c           geometric nonlinear elements, the element coordinates must
c           be updated and so the local nodal displacements
c           must be rotated back to global -- all element computations
c           are performed in global coordinates.
c
c           build table of element nodal coordinates and
c           transformation flags for block.
c           this is done for each node of each element in the block.
c           we then set a unique flag for each element
c           and for the whole block (which can be skipped most times).
c
      do i = 1, span
        trn_e_flags(i) = .false.
      end do
c
      trn_e_block         = .false.
      k = 1
      do j = 1, nnode
!DIR$ VECTOR ALIGNED
         do i = 1, span
            ce(i,k)        = c(bcdst(k,i))
            ce(i,k+1)      = c(bcdst(k+1,i))
            ce(i,k+2)      = c(bcdst(k+2,i))
            ce_0(i,k)      = c(bcdst(k,i))
            ce_0(i,k+1)    = c(bcdst(k+1,i))
            ce_0(i,k+2)    = c(bcdst(k+2,i))
        end do
         do i = 1, span
            trne(i,j)      = trn(belinc(j,i))
            trn_e_flags(i) = trn_e_flags(i) .or. trne(i,j)
            trn_e_block    = trn_e_block .or. trne(i,j)
         end do
         k = k + 3
      end do
c
c           gather element transformation matrices -
c           all dof of all elements in block. skip dof that have
c           no transformation  - their row in transformation matrix
c           table is 0.
c
      if ( trn_e_block ) call duptrans(  span, felem, trnmte )
c
c           gather data for geometrically nonlinear formulation.
c
c             a) get element nodal displacements at start of
c                step (ue) and increment over step (due)
c             b) rotate from constraint (local nodal) to global
c                for elements with nodes that have the local
c                system. can possibly skip whole block.
c             c) update global coordinates of all element nodes
c                for this element block to current estimate for
c                end of step configuration.
c             d) for cohesive elements, compute the reference surface
c                for computations
c             e) for killed elements in the block, set coordinates
c                back to initial (t=0) values.
c             f) gather unrotated cauchy stresses at n+1
c             g) gather [R,n+1] to transform unrotated cauchy
c                stresses to cauchy stresses at n+1
c
c
      if ( .not. geonl ) go to 300
c
      do  j = 1, totdof
!DIR$ VECTOR ALIGNED
       do i = 1, span
          ue(i,j)  = u(bedst(j,i))
          due(i,j) = du(bedst(j,i))
       end do
      end do
c
      if ( trn_e_block ) then
       do i = 1, span
         if ( trn_e_flags(i) ) then
           call trnvec( ue, trnmte, trne, ndof, nnode, i, 2 )
           call trnvec( due, trnmte, trne, ndof, nnode, i, 2 )
         end if
        end do
      end if
c
      do j = 1, totdof
!DIR$ VECTOR ALIGNED
       do i = 1, span
         ce_orig(i,j) = ce(i,j)
         ce(i,j)      = ce(i,j) + ue(i,j) + due(i,j)
       end do
      end do
c
c           set up for the cohesive elements.
c
      middle_surface = surface .eq. 2
!DIR$ VECTOR ALIGNED
      djcoh(1:span)  = zero
      if( cohesive_elem ) then
        if( middle_surface ) call chk_cohes_penetrate( span, mxvl,
     &               felem, mxndel, nnode, elem_type, ce, djcoh )
       call cohes_ref_surface( span, mxvl, mxecor, surface, nnode,
     &                          totdof, ce_orig, ce, djcoh )
      end if
c
c           all elements in a block must be killable or
c           not killable. skip non-killable blocks here.
c           use staged checks since lower data
c           exists only if we use crack growth by killing elements
c           and elements have been killed. if dam_ptr for
c           first element in block = 0, the block has no
c           killable elements (all elements in a block must be
c           killable or non-killable).
c
      if( .not. growth_by_kill ) go to 300
      if(  dam_ptr(felem) .eq. 0 ) go to 300
      do i = 1, span
        element = felem + i - 1
        if ( dam_ptr(element) .eq. 0 ) cycle
        if ( dam_state(dam_ptr(element)) .ne. 0 ) then
          do j = 1, 3*nnode
             ce(i,j) = c(bcdst(j,i))
          end do
        end if
      end do
c
c                 make copies of vectors of subscripts
c                 used in matrix multiplies for element
c                 stiffnesses. this reduces access to shared
c                 global variables during parallel processing
c                 of element blocks.
c
 300  continue
      do i = 1, mxedof
       local_cp(i) = cp(i)
      end do
c
      do i = 1, mxutsz
       local_icp(i,1) = icp(i,1)
       local_icp(i,2) = icp(i,2)
      end do
c
      return
c
      end


module lag_fields
!$$$ module documentation block
!           .      .    .                                       .
! module:   lag_fields
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added module doc block
!   2010-07-14  todling - use die to abort
!   2010-08-19  lueken - add only to module use;no machine code, so use .f90
!   2011-04-20  todling - de-active read and write until further notice
!   2013-10-25  todling - reposition ltosi and others to commvars
!   2020-02-26  todling - reset obsbin from hr to min
!
! subroutines included:
!   sub lag_modini
!   sub lag_guessini
!   sub lag_alloc_uv
!   sub lag_destroy_uv
!   sub lag_destroy_state
!   sub lag_gather_gesuv
!   sub lag_gather_stateuv
!   sub lag_ADscatter_stateuv
!   sub lag_presetup
!   sub lag_state_write
!   sub lag_state_read
!
! variable definitions:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

  use kinds, only: r_kind,i_kind
  use gridmod, only: nsig,ak5,bk5
  use gridmod, only: lat1,lon1,latlon1n
  use gridmod, only: ijn_s,ijn,displs_g,ird_s
  use gridmod, only: iglobal,itotsub
  use general_commvars_mod, only: ltosi,ltosj,ltosi_s,ltosj_s
  use guess_grids, only: nfldsig,hrdifsig
  use constants, only: zero,two,pi,deg2rad
  use gsi_4dvar, only: nobs_bins,mn_obsbin,l4dvar

  use lag_traj, only: lag_initlparam,lag_iteduration
  use lag_traj, only: lag_rk2itenpara_r,lag_rk2itenpara_i
  ! use lag_traj, only: lag_rk4itenpara_r,lag_rk4itenpara_i
  use lag_traj, only: lag_rk2iter_nl
  ! use lag_traj, only: lag_rk4iter_nl

  use lag_interp, only: lag_inipgrid,lag_delpgrid,lag_logcte_p
  use lag_interp, only: lag_index_h
  use mpeu_util, only: die

  implicit none

  private

  ! Constants and variables
  public:: infile_lag,lag_nmax_bal,lag_vorcore_stderr_a,lag_vorcore_stderr_b
  public:: lag_kfirst,lag_klast,lag_kcount

  public:: lag_u_full,lag_v_full,lag_uv_fill,lag_uv_alloc
  public:: ntotal_orig_lag,nlocal_orig_lag
  public:: orig_lag_data,orig_lag_num

  public:: lag_nl_vec,lag_tl_vec,lag_ad_vec
  public:: lag_tl_spec_r,lag_tl_spec_i

  ! Routines
  public:: lag_modini,lag_guessini,lag_presetup
  public:: lag_alloc_uv
  public:: lag_destroy_uv,lag_destroy_state

  public:: lag_gather_gesuv,lag_gather_stateuv,lag_ADscatter_stateuv

  public:: lag_state_write,lag_state_read

  ! File(s) containing the initial positions of balloons
  character(255) ::infile_lag='inistate_lag.dat'
  ! Maximum number of balloon in reference state
  integer(i_kind)::lag_nmax_bal=1000
  ! Observation error for vorcore balloon
  !   error = b + a * timestep(in hours)
  real(r_kind)::lag_vorcore_stderr_a=2.0e3_r_kind
  real(r_kind)::lag_vorcore_stderr_b=zero

  integer(i_kind)::lag_kfirst,lag_klast ! First and last level use
  integer(i_kind)::lag_kcount           ! Number of levels use

  integer(i_kind),parameter::lag_unit_in  =11 ! Unit to read in the ini file
  integer(i_kind),parameter::lag_unit_save=11 ! Unit to read/write the state

  integer(i_kind),parameter::iv_debug=1       ! printing level
  integer(i_kind),parameter::idonothing = 1   ! deactive this code for now

  character(*),parameter::lag_filesave='lagstate.save'  ! File for save/read
                                                        ! the state of the
                                                        ! lag. module

  ! Allocatable arrays to store the whole U and V fields
  !   1st dim: horiz index number
  !   2nd dim: verical level (from kfirst to klast)
  !   3rd dim: obs bin
  real(r_kind),dimension(:,:,:),allocatable::lag_u_full,lag_v_full

  logical,dimension(:),allocatable::lag_uv_fill   ! fields fetched ?
  logical::lag_uv_alloc                           ! allocated ?

  integer(i_kind)::ntotal_orig_lag  ! Total number of balloons present at
                                    ! initial time
  integer(i_kind)::nlocal_orig_lag  ! Total number of balloons affected
                                    ! at this given processor

  ! Location of balloons at the begining of the first obsbin
  real(r_kind)   ,dimension(:,:),allocatable::orig_lag_data
  ! Data associated with balloons (number, processor, internal number)
  integer(i_kind),dimension(:,:),allocatable::orig_lag_num

  ! Vectors to contain NL, TL and AD calculations for each balloon
  ! affected to the processor (not all balloons)
  real(r_kind),dimension(:,:,:),allocatable::lag_nl_vec
  real(r_kind),dimension(:,:,:),allocatable::lag_tl_vec
  real(r_kind),dimension(:,:,:),allocatable::lag_ad_vec

  ! Specifications of TL and AD models
  real(r_kind)   ,dimension(:,:,:),allocatable::lag_tl_spec_r
  integer(i_kind),dimension(:,:,:),allocatable::lag_tl_spec_i

  contains

  ! ------------------------------------------------------------------------
  ! Initialise constants
  subroutine lag_modini
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_modini
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    use constants, only: r60
    implicit none

    ! Initialisation of the model module (lag_traj)
    lag_iteduration=mn_obsbin*r60
    call lag_initlparam()

    ! Not initialised at first
    lag_uv_alloc=.false.

  end subroutine lag_modini
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Allocate the pseudo state vector for lagrangian assimilation by reading
  ! the guess fields
  ! - in 4D var, read only the position at the begining of the assimilation
  !   window (positions for the other obsbin are calculated by lag_presetup)
  ! - in 3D var, read the positions at the begining of the assimilation window,
  !   but also try to read the guess at the times of the atmos. model guess.
  !   If these additional guess are missing, values will be calculated by
  !   lag_presetup (but the result of the assimilation won't be optimal)
  subroutine lag_guessini
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_guessini
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!   2013-01-23  parrish - change from grdcrd to grdcrd1 (to allow successful debug compile on WCOSS)
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    use mpimod, only: mype,npe
    implicit none

    real(r_kind)::lon,lat,p
    integer(i_kind)::num
    real(r_kind),dimension(nsig+1)::pcalc
    real(r_kind),dimension(nsig+1)::tmp_press
    integer(i_kind)::i,j,iferror,nread
    real(r_kind)   ,dimension(:,:),allocatable::tmp_inibal
    integer(i_kind),dimension(:,:),allocatable::tmp_ininum
    real(r_kind),dimension(:),allocatable  ::tmp_inisig
    logical::lerror,leof,lmax,lok
    character(len=255)::tmp_fname

    ! Table of pressure for all levels (standard pressure)
    do i=1,nsig+1
       pcalc(i)=10_r_kind*ak5(i)+1e3_r_kind*bk5(i)
    end do
    do i=1,nsig
       tmp_press(i)=log(sqrt(pcalc(i)*pcalc(i+1)))
    end do

    !Allocate the array to read data
    allocate(tmp_inibal(lag_nmax_bal,3))  ! balloon initial position
    allocate(tmp_ininum(lag_nmax_bal,3))  ! numbers of balloons
    allocate(tmp_inisig(lag_nmax_bal))    ! to store vertical level
    ntotal_orig_lag=0
    nlocal_orig_lag=0

    !open the initial position file
    write(unit=tmp_fname,fmt="(A,'.',I3.3)") trim(infile_lag),1
    open(lag_unit_in,file=trim(tmp_fname),form='formatted',iostat=iferror)
    lerror = (iferror/=0)

    !read the first line
    if (.not.lerror) then
       read(lag_unit_in,fmt=*,iostat=iferror) num,lon,lat,p
       lerror=(iferror>0)
       leof  =(iferror<0)
       lmax  =.false.
    end if

    !loop on the file
    nread=0
    do while (.not.(lerror .or. leof .or. lmax))

       nread=nread+1
       lon=deg2rad*lon
       lat=deg2rad*lat

       lok=(lon>=-pi     .and. lon<=two*pi .and. &
           &lat>=-pi/two .and. lat<=pi/two .and. &
           &p>=zero)

       if (lok) then

          if (lon<zero) lon=lon+two*pi
          ntotal_orig_lag=ntotal_orig_lag+1
          tmp_ininum(ntotal_orig_lag,1)=num ! balloon id number
          tmp_ininum(ntotal_orig_lag,2)=mod(ntotal_orig_lag-1,npe)  ! Processor of
                                                                    ! affectation
          tmp_ininum(ntotal_orig_lag,3)=(ntotal_orig_lag-1)/npe + 1 ! Nr. on processor

          ! Number of balloons affected to this processor
          if (mype==tmp_ininum(ntotal_orig_lag,2)) nlocal_orig_lag=nlocal_orig_lag+1

          tmp_inibal(ntotal_orig_lag,1)=lon ! Balloon data
          tmp_inibal(ntotal_orig_lag,2)=lat
          tmp_inibal(ntotal_orig_lag,3)=p

          ! Calculate the level relative coordinate
          tmp_inisig(ntotal_orig_lag)=log(p)
          call grdcrd1(tmp_inisig(ntotal_orig_lag),tmp_press,nsig,-1)
       end if

       ! read the next one
       read(lag_unit_in,fmt=*,iostat=iferror) num,lon,lat,p
       lerror=(iferror>0)
       leof  =(iferror<0)
       lmax  =nread>=lag_nmax_bal

    end do

    close(lag_unit_in)

    if (mype==0) &
       write(6,'(A,I4,A)') 'LAG_GUESSINI: first guess read. ',&
         &ntotal_orig_lag,' balloons availlable.'

    ! Is there observations ?
    if (ntotal_orig_lag>0) then

       !Allocate the array containing the original positions
       allocate(orig_lag_data(ntotal_orig_lag,3),stat=i)
       if (i /= 0) stop "Allocation failled"
       allocate(orig_lag_num (ntotal_orig_lag,3),stat=i)
       if (i /= 0) stop "Allocation failled"
       orig_lag_data(:,:)=tmp_inibal(1:ntotal_orig_lag,:)
       orig_lag_num(:,:) =tmp_ininum(1:ntotal_orig_lag,:)

       ! Setup the min and max level
       lag_kfirst=floor(  minval(tmp_inisig(1:ntotal_orig_lag)))-1
       lag_klast =ceiling(maxval(tmp_inisig(1:ntotal_orig_lag)))+1
       lag_kcount=lag_klast-lag_kfirst+1

       !Setup the pressure subgrid
       call lag_inipgrid(tmp_press(lag_kfirst:lag_klast))

       !Allocate the distributed state vectors
       if (nlocal_orig_lag/=0) then
          if (l4dvar) then
             allocate(lag_nl_vec(nlocal_orig_lag,nobs_bins,3))
             allocate(lag_tl_vec(nlocal_orig_lag,nobs_bins,3))
             allocate(lag_ad_vec(nlocal_orig_lag,nobs_bins,3))
          else
             allocate(lag_nl_vec(nlocal_orig_lag,nfldsig,3))
             allocate(lag_tl_vec(nlocal_orig_lag,nfldsig,3))
             allocate(lag_ad_vec(nlocal_orig_lag,nfldsig,3))
          end if
          lag_nl_vec=zero;lag_tl_vec=zero; lag_ad_vec=zero
          do i=1,ntotal_orig_lag
             if (mype==orig_lag_num(i,2)) then
                lag_nl_vec(orig_lag_num(i,3),1,:)=orig_lag_data(i,:)
             end if
          end do
       end if

       !Allocate the distributed TL model definition
       if (nlocal_orig_lag/=0 .and. nobs_bins>1) then
          allocate(lag_tl_spec_r(nlocal_orig_lag,nobs_bins-1,lag_rk2itenpara_r))
          allocate(lag_tl_spec_i(nlocal_orig_lag,nobs_bins-1,lag_rk2itenpara_i))
       end if

       !If in 3Dvar, try to read the other guess fields
       if (.not.l4dvar) then

          ! If there is several obsbin in 3Dvar it will really blow up, so...
          if (nobs_bins/=1) &
            &call die('LAG_GUESSINI: only 1 obsbin can be handle in 3Dvar')

          do i=2,nfldsig

             if (mype==0) &
                write(6,'(A,I2,A)') 'LAG_GUESSINI: 3Dvar try to read guess ',i,'.'

             !open the initial position file
             write(unit=tmp_fname,fmt="(A,'.',I3.3)") trim(infile_lag),i
             open(lag_unit_in,file=trim(tmp_fname),form='formatted',iostat=iferror)
             lerror = (iferror/=0)

             !read the first line
             if (.not.lerror) then
                read(lag_unit_in,fmt=*,iostat=iferror) num,lon,lat,p
                lerror=(iferror>0)
                leof  =(iferror<0)
                lmax  =.false.
             end if

             !loop on the file
             do while (.not.(lerror .or. leof .or. lmax))

                lon=deg2rad*lon
                lat=deg2rad*lat

                lok=(lon>=-pi     .and. lon<=two*pi .and. &
                    &lat>=-pi/two .and. lat<=pi/two .and. &
                    &p>=zero)

                ! If good, store in the appropriate array
                if (lok) then
                   if (lon<zero) lon=lon+two*pi

                   do j=1,ntotal_orig_lag
                      if (orig_lag_num(j,1)==num .and. orig_lag_num(j,2)==mype) then
                         lag_nl_vec(orig_lag_num(j,3),i,1)=lon
                         lag_nl_vec(orig_lag_num(j,3),i,2)=lat
                         lag_nl_vec(orig_lag_num(j,3),i,3)=p
                      end if
                   end do

                end if

                ! read the next one
                read(lag_unit_in,fmt=*,iostat=iferror) num,lon,lat,p
                lerror=(iferror>0)
                leof  =(iferror<0)
                lmax  =nread>=lag_nmax_bal

             end do

             close(lag_unit_in)

          end do ! nfldsig

       end if ! 3D var read next guesses

    end if ! ntotal_orig_lag>0

    !cleaning
    deallocate(tmp_inibal,tmp_ininum,tmp_inisig)

    !debug printing
    if (iv_debug>=1) then
       if (mype==0) then
          print *,'GUESS NUM',orig_lag_num
          print *,'GUESS kfirst, klast',lag_kfirst,lag_klast
       end if
       do i=1,size(lag_nl_vec,2)
          do j=1,size(lag_nl_vec,1)
             print '(A,I2.2,A,I2.2,A,I2.2,A,F12.6,F12.6,F12.6)',&
               &'GUESS ',i,' MYPE ',mype,' LOC# ',j,' POS ',lag_nl_vec(j,i,:)
          end do
       end do
    end if

  end subroutine lag_guessini
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Allocate the u and v fields
  subroutine lag_alloc_uv
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_alloc_uv
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    if (.not.lag_uv_alloc) then
       allocate(lag_u_full(iglobal,lag_kcount,max(nobs_bins,nfldsig)))
       allocate(lag_v_full(iglobal,lag_kcount,max(nobs_bins,nfldsig)))
       allocate(lag_uv_fill(max(nobs_bins,nfldsig)))
       lag_u_full=zero; lag_v_full=zero
       lag_uv_fill(:)=.false.
       lag_uv_alloc  =.true.
    end if

  end subroutine lag_alloc_uv
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Deallocate the u and v fields
  subroutine lag_destroy_uv
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_destroy_uv
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    if (lag_uv_alloc) then
       deallocate(lag_u_full)
       deallocate(lag_v_full)
       deallocate(lag_uv_fill)
       lag_uv_alloc=.false.
    end if

  end subroutine lag_destroy_uv
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Deallocate the state parameters for the lagrangian assimilation
  subroutine lag_destroy_state
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_destroy_state
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block
    implicit none

    if (allocated(lag_nl_vec)) deallocate(lag_nl_vec)
    if (allocated(lag_tl_vec)) deallocate(lag_tl_vec)
    if (allocated(lag_ad_vec)) deallocate(lag_ad_vec)

    if (allocated(lag_tl_spec_r)) deallocate(lag_tl_spec_r)
    if (allocated(lag_tl_spec_i)) deallocate(lag_tl_spec_i)

    if (allocated(orig_lag_data)) deallocate(orig_lag_data)
    if (allocated(orig_lag_num))  deallocate(orig_lag_num)

  end subroutine lag_destroy_state
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Gather the the guess fields for u and v, for obsbin time hrdifsig(t)
  ! (using global variables ges_u and ges_v).
  subroutine lag_gather_gesuv(itt)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_gather_gesuv
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!   2010-04-01  treadon - move strip and reorder to gridmod
!   2013-10-19  todling - metguess now holds background
!
!   input argument list:
!    itt
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use mpimod, only: mype,mpi_comm_world,mpi_rtype
    use gridmod, only: strip,reorder
    use gsi_bundlemod, only : gsi_bundlegetpointer
    use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle

    implicit none

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

    integer(i_kind):: k,i
    integer(i_kind):: ierror,istatus
    real(r_kind),dimension(lat1*lon1,nsig):: ustrip,vstrip
    real(r_kind),dimension(:),allocatable::  worku,workv
    real(r_kind),dimension(:,:,:),pointer::  ges_u_itt=>NULL()
    real(r_kind),dimension(:,:,:),pointer::  ges_v_itt=>NULL()

    ! Security
    if (ntotal_orig_lag==0) return

    ierror=0
    call gsi_bundlegetpointer(gsi_metguess_bundle(itt),'u',ges_u_itt,istatus)
    ierror=ierror+istatus
    call gsi_bundlegetpointer(gsi_metguess_bundle(itt),'v',ges_v_itt,istatus)
    ierror=ierror+istatus
    if(ierror/=0) return

    ! allocations
    call lag_alloc_uv()
    allocate(worku(max(iglobal,itotsub)))
    allocate(workv(max(iglobal,itotsub)))

    ! strip buffer parts of ges_u and ges_v
    call strip(ges_u_itt,ustrip,nsig)
    call strip(ges_v_itt,vstrip,nsig)

    ! gather the fields only for the predefined level range
    do k=lag_kfirst,lag_klast
       call mpi_allgatherv(ustrip(1,k),ijn(mype+1),mpi_rtype,&
         worku,ijn,displs_g,mpi_rtype,mpi_comm_world,ierror)
       call mpi_allgatherv(vstrip(1,k),ijn(mype+1),mpi_rtype,&
         workv,ijn,displs_g,mpi_rtype,mpi_comm_world,ierror)
       call reorder(worku,1,1)
       call reorder(workv,1,1)
       do i=1,iglobal
          lag_u_full(lag_index_h(ltosj(i),ltosi(i)),k-lag_kfirst+1,itt)=worku(i)
          lag_v_full(lag_index_h(ltosj(i),ltosi(i)),k-lag_kfirst+1,itt)=workv(i)
       end do
    end do

    lag_uv_fill(itt)=.true.

    deallocate(worku)
    deallocate(workv)

  end subroutine lag_gather_gesuv
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Gather the increments fields for u and v, taking increments in the
  ! subdomains state vectors svalu and svalv. for obsbin t.
  subroutine lag_gather_stateuv(svalu,svalv,itt)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_gather_stateuv
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!   2010-04-01  treadon - move strip and reorder to gridmod
!
!   input argument list:
!    svalu,svalv
!    itt
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use mpimod, only: mype,mpi_comm_world,mpi_rtype
    use gridmod, only: strip,reorder,lat2,lon2
    implicit none

    real(r_kind),dimension(latlon1n),intent(in   ) :: svalu,svalv
    integer(i_kind)                 ,intent(in   ) :: itt

    integer(i_kind):: k,i
    integer(i_kind):: ierror
    real(r_kind),dimension(lat1*lon1,nsig):: ustrip,vstrip
    real(r_kind),dimension(:),allocatable::  worku,workv

    ! Security
    if (ntotal_orig_lag==0) return

    ! allocations
    call lag_alloc_uv()
    allocate(worku(max(iglobal,itotsub)))
    allocate(workv(max(iglobal,itotsub)))

    ! strip buffer parts of ges_u and ges_v
    call strip(reshape(svalu,(/lat2,lon2,nsig/)),ustrip,nsig)
    call strip(reshape(svalv,(/lat2,lon2,nsig/)),vstrip,nsig)

    ! gather the fields only for the predefined level range
    do k=lag_kfirst,lag_klast
       call mpi_allgatherv(ustrip(1,k),ijn(mype+1),mpi_rtype,&
         worku,ijn,displs_g,mpi_rtype,mpi_comm_world,ierror)
       call mpi_allgatherv(vstrip(1,k),ijn(mype+1),mpi_rtype,&
         workv,ijn,displs_g,mpi_rtype,mpi_comm_world,ierror)
       call reorder(worku,1,1)
       call reorder(workv,1,1)
       do i=1,iglobal
          lag_u_full(lag_index_h(ltosj(i),ltosi(i)),k-lag_kfirst+1,itt)=worku(i)
          lag_v_full(lag_index_h(ltosj(i),ltosi(i)),k-lag_kfirst+1,itt)=workv(i)
       end do
    end do

    lag_uv_fill(itt)=.true.

    deallocate(worku)
    deallocate(workv)

  end subroutine lag_gather_stateuv
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Scatter the adjoint increments back in subdomain fields for u and v.
  !  - Adjoint increments are added in subdomain state vectors svalu & svalv
  !  - Adjoint increments are read in global domain arrays lag_u_full and
  !    lag_v_full at obsbin t
  subroutine lag_ADscatter_stateuv(svalu,svalv,itt)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_ADscatter_stateuv
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!   2010-04-01  treadon - move reorder2 to gridmod
!
!   input argument list:
!    svalu,svalv
!    itt
!
!   output argument list:
!    svalu,svalv
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use mpimod, only: mype,mpi_comm_world,mpi_rtype,mpi_sum
    use gridmod, only: reorder2
    implicit none

    real(r_kind),dimension(latlon1n),intent(inout) :: svalu, svalv
    integer(i_kind)                 ,intent(in   ) :: itt

    integer(i_kind):: k,i
    integer(i_kind):: ierror
    real(r_kind),dimension(:,:),allocatable::  worku ,workv
    real(r_kind),dimension(:),allocatable::  worku2,workv2

    integer(i_kind)::hdisp_glo1,hdisp_glo2,hdisp_sub1,hdisp_sub2

    ! lag_u_full & lag_v_full must be there
    if (.not.lag_uv_alloc .or. ntotal_orig_lag==0) return

    allocate(worku(iglobal,lag_kcount))
    allocate(workv(iglobal,lag_kcount))
    allocate(worku2(itotsub))
    allocate(workv2(itotsub))

    ! Sum the adjoint increments calculated on the whole grid by each
    ! processors
    call mpi_allreduce(lag_u_full(1,1,itt),worku,iglobal*lag_kcount,&
      mpi_rtype,mpi_sum,mpi_comm_world,ierror)
    call mpi_allreduce(lag_v_full(1,1,itt),workv,iglobal*lag_kcount,&
      mpi_rtype,mpi_sum,mpi_comm_world,ierror)
    ! print *,'Mype',mype,'Contribution total worku',sum(worku)

    ! Extract the part of the previously reduced grid for the given subdomain
    do k=lag_kfirst,lag_klast

       ! reorder all the elements to obtain the same shape than svalu & svalv
       do i=1,itotsub
          worku2(i)=worku(lag_index_h(ltosj_s(i),ltosi_s(i)),k-lag_kfirst+1)
          workv2(i)=workv(lag_index_h(ltosj_s(i),ltosi_s(i)),k-lag_kfirst+1)
       end do
       call reorder2(worku2,1,1)
       call reorder2(workv2,1,1)
       ! if (k==lag_kfirst+1) print *,'Mype',mype,'Contribution total worku2',sum(worku2)

       ! indexes in the arrays
       hdisp_glo1=ird_s(mype+1)+1
       hdisp_glo2=ird_s(mype+1)+ijn_s(mype+1)-1
       hdisp_sub1=1+ijn_s(mype+1)*(k-1)
       hdisp_sub2=hdisp_sub1+ijn_s(mype+1)-1

       svalu(hdisp_sub1:hdisp_sub2)=&
         svalu(hdisp_sub1:hdisp_sub2) + worku2(hdisp_glo1:hdisp_glo2)
       ! if (k==lag_kfirst+1) print *,'Mype',mype,'Svalu',sum(svalu)

       svalv(hdisp_sub1:hdisp_sub2)=&
         svalv(hdisp_sub1:hdisp_sub2) + workv2(hdisp_glo1:hdisp_glo2)

    end do

    deallocate(worku)
    deallocate(workv)
    deallocate(worku2)
    deallocate(workv2)

  end subroutine lag_ADscatter_stateuv
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! 1. Load the entire wind guess in memory.
  ! 2. In 4Dvar, perfom the non-linear trajectory integration for all balloons
  ! affected to this processor. Subsequently save the parameters for the TL
  ! model.
  ! 3. In 3Dvar, perfom the non-linear trajectory integration for all balloons
  ! affected to this processor only if the postion as not been read previously
  ! in guess files. (for an optimal 3Dvar, values should be read in guess files)
  subroutine lag_presetup
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_presetup
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use constants, only: r3600
    use mpimod, only: mype
    implicit none

    integer(i_kind)::i,j,k,itime
    real(r_kind)::fieldtime

    ! If no balloons do nothing
    if (ntotal_orig_lag>0) then

       ! Load the wind field guess in memory
       do i=1,nfldsig
          call lag_gather_gesuv(i)
          if (iv_debug>=1) print '(A,I2,A,I2)','LAG_PRESETUP: Mype',mype,&
            &'. Gather u,v guess',i
       end do

       ! 4Dvar, Perform the NL integration given this guess fo each obsbin
       if (l4dvar .and. nobs_bins>1) then
          do i=2,nobs_bins

             fieldtime=(i-2)*mn_obsbin
             if(fieldtime>=hrdifsig(1) .and. fieldtime<=hrdifsig(nfldsig)) then

                ! Which guess field to use
                do k=1,nfldsig-1
                   if(fieldtime >= hrdifsig(k) .and. fieldtime <= hrdifsig(k+1)) then
                      itime=k
                   end if
                end do

                do j=1,nlocal_orig_lag
                   lag_nl_vec(j,i,:)=lag_nl_vec(j,i-1,:)
                   call lag_rk2iter_nl(&
                     &lag_nl_vec(j,i,1),lag_nl_vec(j,i,2),lag_nl_vec(j,i,3),&
                     &lag_u_full(:,:,itime),lag_v_full(:,:,itime),&
                     &lag_iteduration,&
                     &lag_tl_spec_i(j,i-1,:),lag_tl_spec_r(j,i-1,:))
                end do

             else
                call die('lag_presetup: Inapropriate velocity guess fields to &
                  & compute trajectories')
             end if

          end do
       end if ! l4dvar

       ! 3Dvar, Perform the NL integration given this guess fo each guess time
       ! (if needed only)
       if (.not.l4dvar .and. nfldsig>1) then

          do i=2,nfldsig
             do j=1,nlocal_orig_lag
                ! If the guess add already been read do nothing
                if (lag_nl_vec(j,i,3)==zero) then
                   lag_nl_vec(j,i,:)=lag_nl_vec(j,i-1,:)
                   call lag_rk2iter_nl(&
                     &lag_nl_vec(j,i,1),lag_nl_vec(j,i,2),lag_nl_vec(j,i,3),&
                     &lag_u_full(:,:,i-1),lag_v_full(:,:,i-1),&
                     &(hrdifsig(i)-hrdifsig(i-1))*r3600)
                end if
             end do
          end do

       end if ! not l4dvar

       !debug printing
       if (iv_debug>=1) then
          do i=1,size(lag_nl_vec,2)
             do j=1,size(lag_nl_vec,1)
                print '(A,I2.2,A,I2.2,A,I2.2,A,F12.6,F12.6,F12.6)',&
                  &'PRESETUP ',i,' MYPE ',mype,' LOC# ',j,' POS ',lag_nl_vec(j,i,:)
             end do
          end do
       end if

    end if ! ntotal_orig_lag>0

  end subroutine lag_presetup
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Save all the lagrangian parameters in a file (1 file per task)
  subroutine lag_state_write()
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_state_write
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use mpimod, only: mype
    implicit none

    character(len=255)::loc_filename
    integer(i_kind)::istat

    ! RTodling: Return for now - this code is innactive
    if(idonothing/=0) return

    ! Create the filename with the mype number
    write(loc_filename,fmt="(A,'.',I4.4)") lag_filesave,mype
    ! Open result file
    open(unit=lag_unit_save,file=trim(loc_filename),iostat=istat,&
      form='unformatted',action='write')
    if (istat/=0) call die('lag_state_write: Unable to open file');

    write(lag_unit_save) ntotal_orig_lag, nlocal_orig_lag

    if (ntotal_orig_lag>0) then

       write(lag_unit_save) lag_kfirst,lag_klast
       write(lag_unit_save) lag_logcte_p

       write(lag_unit_save) orig_lag_data, orig_lag_num

       if (nlocal_orig_lag>0) then
          write(lag_unit_save) lag_nl_vec

          if (nobs_bins>1) write(lag_unit_save) lag_tl_spec_r, lag_tl_spec_i
       end if

    end if

    close(lag_unit_save,iostat=istat)
    if (istat/=0) call die('lag_state_write: Unable to close file');

  end subroutine lag_state_write
  ! ------------------------------------------------------------------------

  ! ------------------------------------------------------------------------
  ! Read all the lagrangian parameters in a file (1 file per task)
  subroutine lag_state_read()
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    lag_state_read
!   prgmmr:
!
! abstract:
!
! program history log:
!   2009-08-05  lueken - added subprogram doc block
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:
!
!$$$ end documentation block

    use mpimod, only: mype
    implicit none

    character(len=255)::loc_filename
    integer(i_kind)::istat
    real(r_kind),dimension(:),allocatable::tmp_pgrid

    ! RTodling: Return for now - this code is innactive
    if(idonothing/=0) return

    ! Create the filename with the mype number
    write(unit=loc_filename,fmt="(A,'.',I4.4)") lag_filesave,mype
    ! Open result file
    open(unit=lag_unit_save,file=trim(loc_filename),iostat=istat,&
      form='unformatted',action='read')
    if (istat/=0) call die('lag_state_read: Unable to open file');

    ! First read the number of balloons
    read(lag_unit_save,iostat=istat) ntotal_orig_lag, nlocal_orig_lag
    if (istat/=0) call die('lag_state_read: Unable to read # of balloons')

    ! Start from scratch
    call lag_destroy_state()

    if (ntotal_orig_lag>0) then

       read(lag_unit_save,iostat=istat)  lag_kfirst,lag_klast
       if (istat/=0) call die('lag_state_read: Unable to read pgrid par.')
       lag_kcount=lag_klast-lag_kfirst+1

       allocate(tmp_pgrid(lag_kcount),stat=istat)
       if (istat/=0) call die('lag_state_read: err. alloc. tmp_pgrid')

       allocate(orig_lag_data(ntotal_orig_lag,3),stat=istat)
       if (istat/=0) call die('lag_state_read: err. alloc. orig_lag_data')
       allocate(orig_lag_num (ntotal_orig_lag,3),stat=istat)
       if (istat/=0) call die('lag_state_read: err. alloc. orig_lag_num')

       read(lag_unit_save,iostat=istat) tmp_pgrid
       if (istat/=0) call die('lag_state_read: Unable to read pgrid')
       call lag_inipgrid(tmp_pgrid)

       read(lag_unit_save,iostat=istat) orig_lag_data, orig_lag_num
       if (istat/=0) call die('lag_state_read: Unable to read orig_lag*')

       if (nlocal_orig_lag/=0) then

          allocate(lag_nl_vec(nlocal_orig_lag,nobs_bins,3),stat=istat)
          if (istat/=0) call die('lag_state_read: err. alloc. lag_nl_vec')
          allocate(lag_tl_vec(nlocal_orig_lag,nobs_bins,3),stat=istat)
          if (istat/=0) call die('lag_state_read: err. alloc. lag_tl_vec')
          allocate(lag_ad_vec(nlocal_orig_lag,nobs_bins,3),stat=istat)
          if (istat/=0) call die('lag_state_read: err. alloc. lag_ad_vec')
          lag_tl_vec=zero; lag_ad_vec=zero; lag_nl_vec=zero;

          read(lag_unit_save,iostat=istat) lag_nl_vec
          if (istat/=0) call die('lag_state_read: Unable to read lag_nl_vec')

          if (nobs_bins>1) then

             allocate(lag_tl_spec_r(nlocal_orig_lag,nobs_bins-1,lag_rk2itenpara_r),&
               stat=istat)
             if (istat/=0) call die('lag_state_read: err. alloc. spec_r')
             allocate(lag_tl_spec_i(nlocal_orig_lag,nobs_bins-1,lag_rk2itenpara_i),&
               stat=istat)
             if (istat/=0) call die('lag_state_read: err. alloc. spec_i')

             read(lag_unit_save,iostat=istat) lag_tl_spec_r, lag_tl_spec_i
             if (istat/=0) call die('lag_state_read: Unable to read spec_*')

          end if

       end if

    end if

    close(lag_unit_save,iostat=istat)
    if (istat/=0) call die('lag_state_read: Unable to close file');

  end subroutine lag_state_read
  ! ------------------------------------------------------------------------

end module lag_fields


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

module dart_time_io_mod

!> \defgroup dart_time_io_mod dart_time_io_mod
!> Default routines for netCDF reading and writing dart model time.
!> If your model uses a different name for the time dimension
!> or has a different way of handing/storing time, it must provide
!> a custom read_model_time() and write_model_time() routine.
!> @{

use types_mod,            only : r8, digits12
use time_manager_mod,     only : time_type, set_time, get_time, print_time, &
                                 set_calendar_type, set_date, get_calendar_string, &
                                 operator(+)

use utilities_mod,        only : E_MSG, E_ERR, error_handler, to_upper
use netcdf_utilities_mod, only : nc_check, nc_open_file_readonly, nc_close_file
use typeSizes
use netcdf

implicit none
private

public :: read_model_time, write_model_time

! version controlled file description for error handling, do not edit
character(len=*), parameter :: source   = "$URL$"
character(len=*), parameter :: revision = "$Revision$"
character(len=*), parameter :: revdate  = "$Date$"

character(len=512) :: string1, string2, string3

contains

!--------------------------------------------------------------------
!> Make a stab at reading the time from the input file
!> and setting the calendar.  This routine assumes the file hasn't
!> been opened yet, and closes it when it's done.

function read_model_time(filename)

character(len=*), intent(in) :: filename
type(time_type)              :: read_model_time

integer :: ncid, ios, numdims, xtype, VarID
integer :: ntimes, seconds, days
integer :: year, month, day, hour, minute, second
type(time_type) :: base_time, delta_time

character(len=*), parameter :: routine = 'read_model_time'
real(digits12) :: model_time, time_array(1)

integer, dimension(NF90_MAX_VAR_DIMS) :: dimIDs
character(len=256) :: file_calendar, dart_calendar
character(len=256) :: unitstring

! this is used in many error messages below.  set it here, and
! don't reuse string3 here, please.
write(string3,*)'You may need to supply a model-specific "read_model_time()" to read the time.'

ncid = nc_open_file_readonly(filename, routine)

ios = nf90_inq_varid(ncid, "time", VarID)
if (ios /= NF90_NOERR) then
   write(string1,*)'Expecting to be able to read the model time from a "time" variable'
   write(string2,*)'in file "'//trim(filename)//'"'
   call error_handler(E_ERR,'read_model_time', string1, &
              source, revision, revdate, text2=string2, text3=string3)
endif

ios = nf90_inquire_variable(ncid, VarID, xtype=xtype, dimids=dimIDs, ndims=numdims)
call nc_check(ios, 'read_model_time', 'inquire_variable "time" from "'//trim(filename)//'"')

if (numdims > 1) then
   write(string1,*)'Expecting the "time" variable to be a single dimension.'
   write(string2,*)'in file "'//trim(filename)//'"'
   call error_handler(E_ERR,'read_model_time', string1, &
              source, revision, revdate, text2=string2, text3=string3)
endif

if (numdims == 0) then
   ios = nf90_get_var(ncid, VarID, model_time)
   call nc_check(ios, 'read_model_time','get_var scalar time' )
else

   ! Since the time variable is known to have only 1 dimension, we know it is the first one.
   ios = nf90_inquire_dimension(ncid, dimIDs(1), len=ntimes)
   call nc_check(ios, 'read_model_time', 'inquire_dimension for time dimension from "'//trim(filename) )

   ! read the last one
   ios = nf90_get_var(ncid, VarID, time_array, start=(/ntimes/), count=(/1/))
   call nc_check(ios, 'read_model_time','get_var time' )
   model_time = time_array(1)
endif

! try to handle the calendar in a generic way

call get_calendar_string(dart_calendar)

ios = nf90_get_att(ncid, VarID, 'calendar', file_calendar)
if (ios /= NF90_NOERR) file_calendar = 'NO_CALENDAR'
call to_upper(file_calendar)

if (dart_calendar /= file_calendar ) then
   ! allow NO_CALENDAR, NO CALENDAR, and NONE to be synonyms.
   ! replace file_calendar with what dart uses to simplify the tests below.
   if (dart_calendar == 'NO_CALENDAR' .and. (file_calendar == 'NONE'        .or. &
                                             file_calendar == 'NO CALENDAR')) then
      file_calendar = 'NO_CALENDAR'
   else
      write(string1,*)'inconsistent calendar types between DART program and input file.'
      write(string2,*)'DART initialized with: ', trim(dart_calendar), ' File uses: ', trim(file_calendar)
      call error_handler(E_ERR, 'read_model_time:', string1, source,revision, revdate, &
                      text2=string2, text3=string3)
   endif
endif

if ( dart_calendar == 'NO_CALENDAR' ) then

   !> assumes time variable is real and fractional days.  if this isn't true,
   !> user has to supply their own read time routine.

   days    = floor(model_time)
   seconds = (model_time-real(days,digits12))*86400
   read_model_time = set_time(seconds, days)

else if ( dart_calendar == 'GREGORIAN' ) then

   ios = nf90_get_att(ncid, VarID, 'units', unitstring)
   call nc_check(ios, 'read_model_time', 'get_att time units "'//trim(filename)//'"')

   if (unitstring(1:10) == 'days since') then

      read(unitstring,'(11x,i4,5(1x,i2))',iostat=ios)year,month,day,hour,minute,second
      if (ios /= 0) then
         write(string1,*)'Unable to interpret time unit attribute. Error status was ',ios
         write(string2,*)'expected "days since YYYY-MM-DD HH:MM:SS", got "'//trim(unitstring)//'"'
         call error_handler(E_ERR, 'read_model_time:', string1, &
                source, revision, revdate, text2=string2, text3=string3)
      endif

      ! This is the start of their calendar
      base_time = set_date(year, month, day, hour, minute, second)

      days    = floor(model_time)
      seconds = (model_time-real(days,digits12))*86400

      delta_time = set_time(seconds, days)
      read_model_time = base_time + delta_time

   else if (unitstring(1:13) == 'seconds since') then

      read(unitstring,'(14x,i4,5(1x,i2))',iostat=ios)year,month,day,hour,minute,second
      if (ios /= 0) then
         write(string1,*)'Unable to interpret time unit attribute. Error status was ',ios
         write(string2,*)'expected "seconds since YYYY-MM-DD HH:MM:SS", got "'//trim(unitstring)//'"'
         call error_handler(E_ERR, 'read_model_time:', string1, &
                source, revision, revdate, text2=string2, text3=string3)
      endif

      ! This is the start of their calendar
      base_time  = set_date(year, month, day, hour, minute, second)
      delta_time = set_time(seconds)

      read_model_time = base_time + delta_time

   else

      write(string1, *) 'looking for "days since" or "seconds since" in the "units" attribute'
      call error_handler(E_ERR, 'read_model_time:', 'unable to set base time for gregorian calendar', &
                         source, revision, revdate, text2=string1, text3=string3)

   endif
else
   call error_handler(E_ERR, 'read_model_time:', &
    'calendar type "'//trim(dart_calendar)//'" unsupported by default read_model_time() routine', &
                      source, revision, revdate, text2=string3)
endif

!>@todo FIXME: do we really want this to print from any
!> task without being asked?  i vote no.
call print_time(read_model_time,'read_model_time')

!>@todo FIXME:
! make print_date() return without error if calendar is no_calendar,
! and then add a call to print_date() here.  (also vote no.)

call nc_close_file(ncid, routine)

end function read_model_time

!--------------------------------------------------------------------
!> Write time to a netcdf file.
!> This routine assumes the file comes in already opened, and doesn't close it.

subroutine write_model_time(ncid, dart_time)

integer,             intent(in) :: ncid
type(time_type),     intent(in) :: dart_time

character(len=*), parameter :: routine = 'write_model_time'
integer  :: ios
integer  :: numdims, ntimes
integer  :: VarID
integer  :: dart_days, dart_seconds
integer  :: unlimitedDimId

logical :: has_unlimited, time_is_unlimited

real(digits12) :: model_time

integer, dimension(NF90_MAX_VAR_DIMS) :: dimIDs
character     (len=NF90_MAX_NAME)     :: dart_calendar, var_calendar

! If there is no unlimited dimension, unlimitedDimID = -1
ios = nf90_inquire(ncid, unlimitedDimId=unlimitedDimId )
call nc_check(ios,routine,'checking unlimited dimension')

has_unlimited = (unlimitedDimID /= -1)

! this is used in many error messages below.  set it here, and
! don't reuse string3 here, please.
write(string3,*)'You may need to supply a model-specific "write_model_time()" to write the time.'

! see what kind of calendar dart is currently running with.
call get_calendar_string(dart_calendar)

ios = nf90_inq_varid(ncid, "time", VarID)

! if the file doesn't already have a "time" variable, we make one
if (ios /= NF90_NOERR) then

   call error_handler(E_MSG, routine, 'no variable "time" found in file', &
              source, revision, revdate, text2='creating one')

   ! begin define mode
   ios = nf90_Redef(ncid)
   call nc_check(ios, routine, "redef")

   ! check to see if there is a time dimension
   ! if it does not exist create it
   ios = nf90_inq_dimid(ncid, "time", dimIDs(1))
   if (ios /= NF90_NOERR) then

      ! If there is already an unlimited dimension, just make a
      ! time dimension of 'normal' size. If there is no unlimited dim already
      ! make the time variable 'unlimited'.

      if (has_unlimited) then
         ios = nf90_def_dim(ncid, "time", 1, dimIDs(1))
         call nc_check(ios, routine, 'def_dim singleton dimension time')
      else
         ios = nf90_def_dim(ncid, "time", nf90_unlimited, dimIDs(1))
         call nc_check(ios, routine, 'def_dim unlimited dimension time')
         has_unlimited = .true.
         unlimitedDimID = dimIDs(1)
      endif

   endif

   ! make the time variable be dimensioned time(time) which is the
   ! netCDF convention for coordinate variables (variables with the
   ! same name as a dimension).
   ios = nf90_def_var(ncid, name="time", xtype=nf90_double, dimids=dimIDs(1), varid=VarID)
   call nc_check(ios, routine, "time def_var")

   ! define time attributes consistent with CF convention
   ios = nf90_put_att(ncid, VarID, "long_name", "valid time of the model state")
   call nc_check(ios, routine, "time long_name")

   if (dart_calendar == 'NO_CALENDAR') then
      ios = nf90_put_att(ncid, VarID, "calendar", "none")
      call nc_check(ios, routine, "calendar long_name")

      ! ncview (actually, probably udunits2) crashes or errors out or
      ! displays misleading plot axes if you use 'days since ...' as the units.
      ! if you simply use 'days' it works much better.

      ios = nf90_put_att(ncid, VarID, "units", "days")
      call nc_check(ios, routine, "units long_name")

   else if (dart_calendar == 'GREGORIAN') then
      ios = nf90_put_att(ncid, VarID, "calendar", "gregorian")
      call nc_check(ios, routine, "calendar long_name")

      ios = nf90_put_att(ncid, VarID, "units", "days since 1601-01-01 00:00:00")
      call nc_check(ios, routine, "units long_name")
   else
      write(string1,*) 'calendar type "'//trim(dart_calendar)// &
                       &'" unsupported by default write_model_time() routine'
      call error_handler(E_ERR, routine, string1, &
                 source, revision, revdate, text2=string3)
   endif

   ! end define mode
   call nc_check( nf90_Enddef(ncid),routine, "Enddef" )
endif

! See if the existing time variable has a calendar and start date to consider

ios = nf90_get_att(ncid, VarID, 'calendar', var_calendar)
if (ios /= NF90_NOERR) var_calendar = 'NO_CALENDAR'
call to_upper(var_calendar)

if (dart_calendar /= var_calendar ) then
   ! allow NO_CALENDAR, NO CALENDAR, and NONE to be synonyms.
   ! replace var_calendar with what dart uses to simplify the tests below.
   if (dart_calendar == 'NO_CALENDAR' .and. (var_calendar == 'NONE'        .or. &
                                             var_calendar == 'NO CALENDAR')) then
      var_calendar = 'NO_CALENDAR'
   else
      write(string1,*)'inconsistent calendar types between DART program and input file.'
      write(string2,*)'DART initialized with: ', trim(dart_calendar), ' File uses: ', trim(var_calendar)
      call error_handler(E_ERR, routine, string1, source, revision, revdate, &
                      text2=string2, text3=string3)
   endif
endif

! convert time to something that netCDF can store, fractional days
call get_time(dart_time, dart_seconds, dart_days)
model_time = real(dart_days,digits12) + real(dart_seconds,digits12)/86400.0_digits12

! need to know how long the time variable is and hammer the last time
ios = nf90_inquire_variable(ncid, VarID, dimids=dimIDs, ndims=numdims)
call nc_check(ios, routine, 'inquire number of dimensions of variable "time"')

if (numdims == 0) then ! variable is a scalar
   ios = nf90_put_var(ncid, VarID, model_time)
   call nc_check(ios, routine, 'put_var scalar "model_time"')
   return
endif

if (numdims > 1) then
   write(string1,*)'Expecting the "time" variable to be a single dimension.'
   call error_handler(E_ERR, routine, string1, &
              source, revision, revdate, text2=string3)
endif

ios = nf90_inquire_dimension(ncid, dimIDs(1), len=ntimes)
call nc_check(ios, routine, 'inquire_dimension for time dimension')

if (dimIDs(1) == unlimitedDimID) time_is_unlimited = .true.

if (ntimes == 0 .and. time_is_unlimited) then
   ntimes = ntimes + 1
elseif (ntimes == 0) then
   write(string1,*)'"time" variable has length 0 but is not the unlimited dimension.'
   call error_handler(E_ERR, routine, string1, &
              source, revision, revdate, text2=string3)
endif

! write dart days and seconds files to netcdf file
ios = nf90_put_var(ncid, VarID, model_time, start=(/ ntimes /))
call nc_check(ios, routine, "put_var model_time")

end subroutine write_model_time

!--------------------------------------------------------------------
!> @}
end module dart_time_io_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1997  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ###############################################################
c     ##                                                           ##
c     ##  subroutine groups  --  group membership of set of atoms  ##
c     ##                                                           ##
c     ###############################################################
c
c
c     "groups" tests a set of atoms to see if all are members
c     of a single atom group or a pair of atom groups; if so,
c     then the correct intra- or intergroup weight is assigned
c
c
      subroutine groups (proceed,weigh,ia,ib,ic,id,ie,ig)
      implicit none
      include 'sizes.i'
      include 'group.i'
      integer ia,ib,ic
      integer id,ie,ig
      integer iga,igb,igc
      integer igd,ige,igg
      integer nset
      integer gmax,gmin
      real*8 weigh
      logical proceed
c
c
c     determine the number of atoms in the set to be compared
c
      nset = 0
      weigh = 0.0d0
      if (ig .ne. 0) then
         nset = 6
      else if (ie .ne. 0) then
         nset = 5
      else if (id .ne. 0) then
         nset = 4
      else if (ic .ne. 0) then
         nset = 3
      else if (ib .ne. 0) then
         nset = 2
      else if (ia .ne. 0) then
         nset = 1
      end if
c
c     check group membership for a set containing one atom
c
      if (nset .eq. 1) then
         iga = grplist(ia)
         weigh = wgrp(iga,iga)
c
c     check group membership for a set containing two atoms
c
      else if (nset .eq. 2) then
         iga = grplist(ia)
         igb = grplist(ib)
         weigh = wgrp(iga,igb)
c
c     check group membership for a set containing three atoms
c
      else if (nset .eq. 3) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         if (iga.eq.igb .or. igb.eq.igc) then
            weigh = wgrp(iga,igc)
         else if (iga .eq. igc) then
            weigh = wgrp(iga,igb)
         end if
c
c     check group membership for a set containing four atoms
c
      else if (nset .eq. 4) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         igd = grplist(id)
         gmin = min(iga,igb,igc,igd)
         gmax = max(iga,igb,igc,igd)
         if ((iga.eq.gmin .or. iga.eq.gmax) .and.
     &       (igb.eq.gmin .or. igb.eq.gmax) .and.
     &       (igc.eq.gmin .or. igc.eq.gmax) .and.
     &       (igd.eq.gmin .or. igd.eq.gmax))  weigh = wgrp(gmin,gmax)
c
c     check group membership for a set containing five atoms
c
      else if (nset .eq. 5) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         igd = grplist(id)
         ige = grplist(ie)
         gmin = min(iga,igb,igc,igd,ige)
         gmax = max(iga,igb,igc,igd,ige)
         if ((iga.eq.gmin .or. iga.eq.gmax) .and.
     &       (igb.eq.gmin .or. igb.eq.gmax) .and.
     &       (igc.eq.gmin .or. igc.eq.gmax) .and.
     &       (igd.eq.gmin .or. igd.eq.gmax) .and.
     &       (ige.eq.gmin .or. ige.eq.gmax))  weigh = wgrp(gmin,gmax)
c
c     check group membership for a set containing five atoms
c
      else if (nset .eq. 6) then
         iga = grplist(ia)
         igb = grplist(ib)
         igc = grplist(ic)
         igd = grplist(id)
         ige = grplist(ie)
         igg = grplist(ig)
         gmin = min(iga,igb,igc,igd,ige,igg)
         gmax = max(iga,igb,igc,igd,ige,igg)
         if ((iga.eq.gmin .or. iga.eq.gmax) .and.
     &       (igb.eq.gmin .or. igb.eq.gmax) .and.
     &       (igc.eq.gmin .or. igc.eq.gmax) .and.
     &       (igd.eq.gmin .or. igd.eq.gmax) .and.
     &       (ige.eq.gmin .or. ige.eq.gmax) .and.
     &       (igg.eq.gmin .or. igg.eq.gmax))  weigh = wgrp(gmin,gmax)
      end if
c
c     interaction will be used if its group has nonzero weight
c
      if (weigh .eq. 0.0d0) then
         proceed = .false.
      else
         proceed = .true.
      end if
      return
      end


!
!                Parallel Sparse BLAS  version 3.5
!      (C) Copyright 2006-2018
!        Salvatore Filippone
!        Alfredo Buttari
!
!    Redistribution and use in source and binary forms, with or without
!    modification, are permitted provided that the following conditions
!    are met:
!      1. Redistributions of source code must retain the above copyright
!         notice, this list of conditions and the following disclaimer.
!      2. Redistributions in binary form must reproduce the above copyright
!         notice, this list of conditions, and the following disclaimer in the
!         documentation and/or other materials provided with the distribution.
!      3. The name of the PSBLAS group or the names of its contributors may
!         not be used to endorse or promote products derived from this
!         software without specific written permission.
!
!    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
!    ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
!    TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
!    PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS
!    BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
!    CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
!    SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
!    INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
!    CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
!    ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
!    POSSIBILITY OF SUCH DAMAGE.
!
!
! File: psb_dspsm.f90
!
!
! Subroutine: psb_dsps_vect
!  Performs one of the distributed matrix-vector operations
!
!     Y := alpha * Pr * A-1 * Pc * X + beta * Y,   or
!
!     Y := alpha * D * Pr * A-1 * Pc * X + beta * Y, or
!
!     Y := alpha * Pr * A-1 * Pc * D * X + beta * Y,  or
!
!     Y := alpha * Pr * A-T * Pc * X + beta * Y,   or
!
!     Y := alpha * D * Pr * A-T * Pc * X + beta * Y, or
!
!     Y := alpha * Pr * A-T * Pc * D * X + beta * Y,  or
!
!  X is a distributed
!  vector and T is a M-by-M distributed triangular matrix.
!
!
! Arguments:
!    alpha   -  real.               The scalar alpha.
!    a       -  type(psb_dspmat_type). The sparse matrix containing A.
!    x       -  type(psb_d_vect_type) The input vector containing the entries of ( X ).
!    beta    -  real                The scalar beta.
!    y       -  type(psb_d_vect_type) The input vector containing the entries of ( Y ).
!    desc_a  -  type(psb_desc_type).   The communication descriptor.
!    info    -  integer.               Return code
!    trans   -  character(optional).   Whether A or A'. If not present 'N' is assumed.
!    scale   -  character(optional).   Specify some type of operation with
!                                      the diagonal matrix D.
!    choice  -  integer(optional).     The kind of update to perform on overlap elements.
!    d(:)    -  real, optional      Matrix for diagonal scaling.
!    work(:) -  real, optional      Working area.
!
subroutine  psb_dspsv_vect(alpha,a,x,beta,y,desc_a,info,&
     & trans, scale, choice, diag, work)
  use psb_base_mod, psb_protect_name => psb_dspsv_vect
  use psi_mod
  implicit none

  real(psb_dpk_), intent(in)           :: alpha, beta
  type(psb_d_vect_type), intent(inout)    :: x
  type(psb_d_vect_type), intent(inout)    :: y
  type(psb_dspmat_type), intent(inout)    :: a
  type(psb_desc_type), intent(in)         :: desc_a
  integer(psb_ipk_), intent(out)                    :: info
  type(psb_d_vect_type), intent(inout), optional  :: diag
  real(psb_dpk_), optional, target, intent(inout) :: work(:)
  character, intent(in), optional         :: trans, scale
  integer(psb_ipk_), intent(in), optional           :: choice

  ! locals
  type(psb_ctxt_type) :: ctxt
  integer(psb_ipk_) :: np, me, &
       & err_act, iix, jjx, ia, ja, iia, jja, lldx,lldy, choice_,&
       & ix, iy, ik, jx, jy, i, lld,&
       & m, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm

  character                :: lscale
  integer(psb_ipk_), parameter       :: nb=4
  real(psb_dpk_),pointer :: iwork(:), xp(:), yp(:)
  character                :: itrans
  character(len=20)        :: name, ch_err
  logical                  :: aliw

  name='psb_dspsv_vect'
  info=psb_success_
  call psb_erractionsave(err_act)
  if  (psb_errstatus_fatal()) then
    info = psb_err_internal_error_ ;    goto 9999
  end if

  ctxt=desc_a%get_context()

  call psb_info(ctxt, me, np)
  if (np == -1) then
    info = psb_err_context_error_
    call psb_errpush(info,name)
    goto 9999
  endif

  if (.not.allocated(x%v)) then
    info = psb_err_invalid_vect_state_
    call psb_errpush(info,name)
    goto 9999
  endif
  if (.not.allocated(y%v)) then
    info = psb_err_invalid_vect_state_
    call psb_errpush(info,name)
    goto 9999
  endif

  if (present(choice)) then
    choice_ = choice
  else
    choice_ = psb_avg_
  endif

  if (present(scale)) then
    lscale = psb_toupper(scale)
  else
    lscale = 'U'
  endif

  if (present(trans)) then
    itrans = psb_toupper(trans)
    if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then
      ! Ok
    else
      info = psb_err_iarg_invalid_value_
      call psb_errpush(info,name)
      goto 9999
    end if
  else
    itrans = 'N'
  endif

  m    = desc_a%get_global_rows()
  nrow = desc_a%get_local_rows()
  ncol = desc_a%get_local_cols()
  lldx = x%get_nrows()
  lldy = y%get_nrows()
  if ((info == 0).and.(lldx<ncol)) call x%reall(ncol,info)
  if ((info == 0).and.(lldy<ncol)) call y%reall(ncol,info)

  if (psb_errstatus_fatal()) then
    info=psb_err_from_subroutine_
    ch_err='reall'
    call psb_errpush(info,name,a_err=ch_err)
    goto 9999
  end if

  iwork => null()
  ! check for presence/size of a work area
  liwork= 2*ncol

  if (present(work)) then
    if (size(work) >= liwork) then
      aliw =.false.
    else
      aliw=.true.
    endif
  else
    aliw=.true.
  end if

  if (aliw) then
    allocate(iwork(liwork),stat=info)
    if(info /= psb_success_) then
      info=psb_err_from_subroutine_
      ch_err='psb_realloc'
      call psb_errpush(info,name,a_err=ch_err)
      goto 9999
    end if
  else
    iwork => work
  endif

  iwork(1)=0.d0

  ! Perform local triangular system solve
  if (present(diag)) then
    call a%spsm(alpha,x,beta,y,info,scale=scale,d=diag,trans=trans)
  else
    call a%spsm(alpha,x,beta,y,info,scale=scale,trans=trans)
  end if
  if(info /= psb_success_) then
    info = psb_err_from_subroutine_
    ch_err='dcssm'
    call psb_errpush(info,name,a_err=ch_err)
    goto 9999
  end if

  ! update overlap elements
  if (choice_ > 0) then
    call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
         & done,y%v,desc_a,iwork,info,data=psb_comm_ovr_)

    if (info == psb_success_) call psi_ovrl_upd(y%v,desc_a,choice_,info)
    if (info /= psb_success_) then
      call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
      goto 9999
    end if
  end if

  if (aliw) deallocate(iwork)

  call psb_erractionrestore(err_act)
  return

9999 call psb_error_handler(ctxt,err_act)

  return
end subroutine psb_dspsv_vect
!
! Subroutine: psb_dspsm
!  Performs one of the distributed matrix-vector operations
!
!     sub( Y ) := alpha * Pr * A-1 * Pc *sub( X ) + beta * sub (Y ),   or
!
!     sub( Y ) := alpha * D * Pr * A-1 * Pc * sub( X ) + beta * sub (Y ), or
!
!     sub( Y ) := alpha * Pr * A-1 * Pc * D * sub( X ) + beta * sub (Y ),  or
!
!     sub( Y ) := alpha * Pr * A-T * Pc * sub( X ) + beta * sub (Y ),   or
!
!     sub( Y ) := alpha * D * Pr * A-T * Pc * sub( X ) + beta * sub (Y ), or
!
!     sub( Y ) := alpha * Pr * A-T * Pc * D * sub( X ) + beta * sub (Y ),  or
!
!  where :
!
!        sub( X ) denotes X(1:M,JX:JX+K-1),
!
!        sub( Y ) denotes Y(1:M,JY:JY+K-1).
!
!  sub( X ) is a distributed
!  vector and T is a M-by-M distributed triangular matrix.
!
! Arguments:
!    alpha   -  real.               The scalar alpha.
!    a       -  type(psb_dspmat_type). The sparse matrix containing A.
!    x(:,:)  -  real                The input vector containing the entries of ( X ).
!    beta    -  real                The scalar beta.
!    y(:,:)  -  real                The input vector containing the entries of ( Y ).
!    desc_a  -  type(psb_desc_type).   The communication descriptor.
!    info    -  integer.               Return code
!    trans   -  character(optional).   Whether A or A'. If not present 'N' is assumed.
!    scale   -  character(optional).   Specify some type of operation with
!                                      the diagonal matrix D.
!    choice  -  integer(optional).     The kind of update to perform on overlap elements.
!    d(:)    -  real, optional      Matrix for diagonal scaling.
!    k       -  integer(optional).     The number of right-hand sides.
!    jx      -  integer(optional).     The column offset for ( X ). Default: 1
!    jy      -  integer(optional).     The column offset for ( Y ). Default: 1
!    work(:) -  real, optional      Working area.
!
subroutine  psb_dspsm(alpha,a,x,beta,y,desc_a,info,&
     & trans, scale, choice, diag, k, jx, jy, work)
  use psb_base_mod, psb_protect_name => psb_dspsm
  use psi_mod
  implicit none

  real(psb_dpk_), intent(in)              :: alpha, beta
  real(psb_dpk_), intent(in), target      :: x(:,:)
  real(psb_dpk_), intent(inout), target   :: y(:,:)
  type (psb_dspmat_type), intent(in)        :: a
  type(psb_desc_type), intent(in)           :: desc_a
  integer(psb_ipk_), intent(out)                      :: info
  real(psb_dpk_), intent(in), optional, target      :: diag(:)
  real(psb_dpk_), optional, target, intent(inout)   :: work(:)
  character, intent(in), optional           :: trans, scale
  integer(psb_ipk_), intent(in), optional             :: choice
  integer(psb_ipk_), intent(in), optional             :: k, jx, jy

  ! locals
  type(psb_ctxt_type) :: ctxt
  integer(psb_ipk_) :: np, me,&
       & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,&
       & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm

  integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik
  character                :: lscale
  integer(psb_ipk_), parameter  :: nb=4
  real(psb_dpk_),pointer :: iwork(:), xp(:,:), yp(:,:), id(:)
  character                :: itrans
  character(len=20)        :: name, ch_err
  logical                  :: aliw

  name='psb_dspsm'
  info=psb_success_
  call psb_erractionsave(err_act)
  if (psb_errstatus_fatal()) then
    info = psb_err_internal_error_ ;    goto 9999
  end if

  ctxt=desc_a%get_context()

  call psb_info(ctxt, me, np)
  if (np == -1) then
    info = psb_err_context_error_
    call psb_errpush(info,name)
    goto 9999
  endif

  ! just this case right now
  ia = 1
  ja = 1

  ix = 1
  if (present(jx)) then
    ijx = jx
  else
    ijx = 1
  endif

  iy = 1
  if (present(jy)) then
    ijy = jy
  else
    ijy = 1
  endif

  if (present(k)) then
    lik = min(k,size(x,2)-ijx+1)
    lik = min(lik,size(y,2)-ijy+1)
  else
    lik = min(size(x,2)-ijx+1,size(y,2)-ijy+1)
  endif

  if (present(choice)) then
    choice_ = choice
  else
    choice_ = psb_avg_
  endif

  if (present(scale)) then
    lscale = psb_toupper(scale)
  else
    lscale = 'U'
  endif

  if (present(trans)) then
    itrans = psb_toupper(trans)
    if((itrans == 'N').or.(itrans == 'T').or.  (itrans == 'C')) then
      ! OK
    else
      info = psb_err_iarg_invalid_value_
      call psb_errpush(info,name)
      goto 9999
    end if
  else
    itrans = 'N'
  endif

  m    = desc_a%get_global_rows()
  nrow = desc_a%get_local_rows()
  ncol = desc_a%get_local_cols()
  lldx = size(x,1)
  lldy = size(y,1)

  if((lldx < ncol).or.(lldy < ncol)) then
    info=psb_err_lld_case_not_implemented_
    call psb_errpush(info,name)
    goto 9999
  end if

  ! check for presence/size of a work area
  iwork => null()
  liwork= 2*ncol
  if (present(work)) then
    if (size(work) >= liwork) then
      aliw =.false.
    else
      aliw=.true.
    endif
  else
    aliw=.true.
  end if

  if (aliw) then
    allocate(iwork(liwork),stat=info)
    if(info /= psb_success_) then
      info=psb_err_from_subroutine_
      ch_err='psb_realloc'
      call psb_errpush(info,name,a_err=ch_err)
      goto 9999
    end if
  else
    iwork => work
  endif

  iwork(1)=0.d0

  if(present(diag)) then
    lld = size(diag)
    id => diag
  else
    lld=1
    allocate(id(1))
    id=1.d0
  end if

  ! checking for matrix correctness
  call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
  ! checking for vectors correctness
  if (info == psb_success_) &
       & call psb_chkvect(m,lik,lldx,ix,ijx,desc_a,info,iix,jjx,check_halo=.true.)
  if (info == psb_success_) &
       & call psb_chkvect(m,lik,lldy,iy,ijy,desc_a,info,iiy,jjy,check_halo=.true.)
  if(info /= psb_success_) then
    info=psb_err_from_subroutine_
    ch_err='psb_chkvect/mat'
    call psb_errpush(info,name,a_err=ch_err)
    goto 9999
  end if

  if(ja /= ix) then
    ! this case is not yet implemented
    info = psb_err_ja_nix_ia_niy_unsupported_
  end if

  if((iix /= 1).or.(iiy /= 1)) then
    ! this case is not yet implemented
    info = psb_err_ix_n1_iy_n1_unsupported_
  end if

  if(info /= psb_success_) then
    call psb_errpush(info,name)
    goto 9999
  end if

  ik = lik ! This should not be a problem.
  ! We expect ik to be small, well within IPK
  ! Perform local triangular system solve
  xp => x(iix:lldx,jjx:jjx+ik-1)
  yp => y(iiy:lldy,jjy:jjy+ik-1)
  call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans)

  if(info /= psb_success_) then
    info = psb_err_from_subroutine_
    ch_err='cssm'
    call psb_errpush(info,name,a_err=ch_err)
    goto 9999
  end if

  ! update overlap elements
  if (choice_ > 0) then
    call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),ik,&
         & done,yp,desc_a,iwork,info,data=psb_comm_ovr_)

    if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info)
    if (info /= psb_success_) then
      call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
      goto 9999
    end if
  end if

  if(aliw) deallocate(iwork)
  if(.not.present(diag)) deallocate(id)

  call psb_erractionrestore(err_act)
  return

9999 call psb_error_handler(ctxt,err_act)

  return
end subroutine psb_dspsm
!
! Subroutine: psb_dspsv
!  Performs one of the distributed matrix-vector operations
!
!     Y := alpha * Pr * A-1 * Pc * X + beta * Y,   or
!
!     Y := alpha * D * Pr * A-1 * Pc * X + beta * Y, or
!
!     Y := alpha * Pr * A-1 * Pc * D * X + beta * Y,  or
!
!     Y := alpha * Pr * A-T * Pc * X + beta * Y,   or
!
!     Y := alpha * D * Pr * A-T * Pc * X + beta * Y, or
!
!     Y := alpha * Pr * A-T * Pc * D * X + beta * Y,  or
!
!  X is a distributed
!  vector and T is a M-by-M distributed triangular matrix.
!
!
! Arguments:
!    alpha   -  real.               The scalar alpha.
!    a       -  type(psb_dspmat_type). The sparse matrix containing A.
!    x(:)    -  real                The input vector containing the entries of ( X ).
!    beta    -  real                The scalar beta.
!    y(:)    -  real                The input vector containing the entries of ( Y ).
!    desc_a  -  type(psb_desc_type).   The communication descriptor.
!    info    -  integer.               Return code
!    trans   -  character(optional).   Whether A or A'. If not present 'N' is assumed.
!    scale   -  character(optional).   Specify some type of operation with
!                                      the diagonal matrix D.
!    choice  -  integer(optional).     The kind of update to perform on overlap elements.
!    d(:)    -  real, optional      Matrix for diagonal scaling.
!    work(:) -  real, optional      Working area.
!
subroutine  psb_dspsv(alpha,a,x,beta,y,desc_a,info,&
     & trans, scale, choice, diag, work)
  use psb_base_mod, psb_protect_name => psb_dspsv
  use psi_mod
  implicit none

  real(psb_dpk_), intent(in)              :: alpha, beta
  real(psb_dpk_), intent(in), target      :: x(:)
  real(psb_dpk_), intent(inout), target   :: y(:)
  type(psb_dspmat_type), intent(in)         :: a
  type(psb_desc_type), intent(in)           :: desc_a
  integer(psb_ipk_), intent(out)                      :: info
  real(psb_dpk_), intent(in), optional, target    :: diag(:)
  real(psb_dpk_), optional, target, intent(inout) :: work(:)
  character, intent(in), optional           :: trans, scale
  integer(psb_ipk_), intent(in), optional             :: choice

  ! locals
  type(psb_ctxt_type) :: ctxt
  integer(psb_ipk_) :: np, me, &
       & err_act, iix, jjx, iia, jja, lldx,lldy, choice_,&
       & ik, i, lld, nrow, ncol, liwork, llwork, iiy, jjy, idx, ndm
  integer(psb_lpk_) :: ix, ijx, iy, ijy, m, n, ia, ja, lik, jx, jy

  character                :: lscale
  integer(psb_ipk_), parameter       :: nb=4
  real(psb_dpk_),pointer :: iwork(:), xp(:), yp(:), id(:)
  character                :: itrans
  character(len=20)        :: name, ch_err
  logical                  :: aliw

  name='psb_dspsv'
  info=psb_success_
  call psb_erractionsave(err_act)
  if (psb_errstatus_fatal()) then
    info = psb_err_internal_error_ ;    goto 9999
  end if

  ctxt=desc_a%get_context()

  call psb_info(ctxt, me, np)
  if (np == -1) then
    info = psb_err_context_error_
    call psb_errpush(info,name)
    goto 9999
  endif

  ! just this case right now
  ia = 1
  ja = 1
  ix = 1
  iy = 1
  lik = 1
  ik = 1
  jx = 1
  jy = 1

  if (present(choice)) then
    choice_ = choice
  else
    choice_ = psb_avg_
  endif

  if (present(scale)) then
    lscale = psb_toupper(scale)
  else
    lscale = 'U'
  endif

  if (present(trans)) then
    itrans = psb_toupper(trans)
    if((itrans == 'N').or.(itrans == 'T').or.(itrans == 'C')) then
      ! Ok
    else
      info = psb_err_iarg_invalid_value_
      call psb_errpush(info,name)
      goto 9999
    end if
  else
    itrans = 'N'
  endif

  m    = desc_a%get_global_rows()
  nrow = desc_a%get_local_rows()
  ncol = desc_a%get_local_cols()
  lldx = size(x)
  lldy = size(y)

  if((lldx < ncol).or.(lldy < ncol)) then
    info=psb_err_lld_case_not_implemented_
    call psb_errpush(info,name)
    goto 9999
  end if

  iwork => null()
  ! check for presence/size of a work area
  liwork= 2*ncol

  if (present(work)) then
    if (size(work) >= liwork) then
      aliw =.false.
    else
      aliw=.true.
    endif
  else
    aliw=.true.
  end if

  if (aliw) then
    allocate(iwork(liwork),stat=info)
    if(info /= psb_success_) then
      info=psb_err_from_subroutine_
      ch_err='psb_realloc'
      call psb_errpush(info,name,a_err=ch_err)
      goto 9999
    end if
  else
    iwork => work
  endif

  iwork(1)=0.d0

  if(present(diag)) then
    lld = size(diag)
    id => diag
  else
    lld=1
    allocate(id(1))
    id=1.d0
  end if

  ! checking for matrix correctness
  call psb_chkmat(m,m,ia,ja,desc_a,info,iia,jja)
  ! checking for vectors correctness
  if (info == psb_success_) &
       & call psb_chkvect(m,lik,lldx,ix,jx,desc_a,info,iix,jjx,check_halo=.true.)
  if (info == psb_success_) &
       & call psb_chkvect(m,lik,lldy,iy,jy,desc_a,info,iiy,jjy,check_halo=.true.)
  if(info /= psb_success_) then
    info=psb_err_from_subroutine_
    ch_err='psb_chkvect/mat'
    call psb_errpush(info,name,a_err=ch_err)
    goto 9999
  end if

  if(ja /= ix) then
    ! this case is not yet implemented
    info = psb_err_ja_nix_ia_niy_unsupported_
  end if

  if((iix /= 1).or.(iiy /= 1)) then
    ! this case is not yet implemented
    info = psb_err_ix_n1_iy_n1_unsupported_
  end if

  if(info /= psb_success_) then
    call psb_errpush(info,name)
    goto 9999
  end if

  ! Perform local triangular system solve
  xp => x(iix:lldx)
  yp => y(iiy:lldy)
  call psb_cssm(alpha,a,xp,beta,yp,info,scale=scale,d=diag,trans=trans)

  if(info /= psb_success_) then
    info = psb_err_from_subroutine_
    ch_err='dcssm'
    call psb_errpush(info,name,a_err=ch_err)
    goto 9999
  end if

  ! update overlap elements
  if(choice_ > 0) then
    call psi_swapdata(ior(psb_swap_send_,psb_swap_recv_),&
         & done,yp,desc_a,iwork,info,data=psb_comm_ovr_)

    if (info == psb_success_) call psi_ovrl_upd(yp,desc_a,choice_,info)
    if (info /= psb_success_) then
      call psb_errpush(psb_err_from_subroutine_,name,a_err='Inner updates')
      goto 9999
    end if
  end if

  if (aliw) deallocate(iwork)
  if(.not.present(diag)) deallocate(id)

  call psb_erractionrestore(err_act)
  return

9999 call psb_error_handler(ctxt,err_act)

  return
end subroutine psb_dspsv


\ I/O pin primitives

0x40010800 CONSTANT GPIO_BASE
      0x00 CONSTANT GPIO.CRL   \ reset 0x44444444 port Conf Register Low
      0x04 CONSTANT GPIO.CRH   \ reset 0x44444444 port Conf Register High
      0x08 CONSTANT GPIO.IDR   \ RO              Input Data Register
      0x0C CONSTANT GPIO.ODR   \ reset 0         Output Data Register
      0x10 CONSTANT GPIO.BSRR  \ reset 0         port Bit Set/Reset Reg
      0x14 CONSTANT GPIO.BRR   \ reset 0         port Bit Reset Register

: bit ( u -- u )  \ turn a bit position into a single-bit mask
  1 SWAP LSHIFT ;

: io ( port# pin# -- pin )  \ combine port AND pin into single int
  SWAP 8 LSHIFT OR ;
: io# ( pin -- u )  \ convert pin to bit position
  0x1F AND   ;
: io-mask ( pin -- u )  \ convert pin to bit mask
  io# bit   ;
: io-port ( pin -- u )  \ convert pin to port number (A=0, B=1, etc)
  8 RSHIFT  ;
: io-base ( pin -- addr )  \ convert pin to GPIO base address
  0xF00 AND 2 LSHIFT GPIO_BASE +   ;

: (io@)  (   pin -- pin* addr )
  DUP io-mask SWAP io-base GPIO.IDR  +  ;
: (ioc!) (   pin -- pin* addr )
  DUP io-mask SWAP io-base GPIO.BRR  +  ;
: (ios!) (   pin -- pin* addr )
  DUP io-mask SWAP io-base GPIO.BSRR +  ;
: (iox!) (   pin -- pin* addr )
  DUP io-mask SWAP io-base GPIO.ODR  +  ;
: (io!)  ( f pin -- pin* addr )
  SWAP 0= 0x10 AND + DUP io-mask SWAP io-base GPIO.BSRR + ;

: io@ ( pin -- f )  \ get pin value (0 or -1)
  (io@) @ AND ;
: ioc! ( pin -- )  \ clear pin to low
  (ioc!)  ! ;
: ios! ( pin -- )  \ set pin to high
  (ios!)  ! ;
: iox! ( pin -- )  \ toggle pin, not interrupt safe
  (iox!) DUP @ ROT XOR SWAP ! ;
: io! ( f pin -- )  \ set pin value
  (io!)   ! ;

0b0000 CONSTANT IMODE-ADC    \ input, analog
0b0100 CONSTANT IMODE-FLOAT  \ input, floating
0b1000 CONSTANT IMODE-PULL   \ input, pull-up/down

0b0001 CONSTANT OMODE-PP     \ output, push-pull
0b0101 CONSTANT OMODE-OD     \ output, open drain
0b1001 CONSTANT OMODE-AF-PP  \ alternate function, push-pull
0b1101 CONSTANT OMODE-AF-OD  \ alternate function, open drain

0b01 CONSTANT OMODE-SLOW  \ add to OMODE-* for 2 MHz iso 10 MHz drive
0b10 CONSTANT OMODE-FAST  \ add to OMODE-* for 50 MHz iso 10 MHz drive

: io-mode! ( mode pin -- )  \ set the CNF AND MODE bits for a pin
  DUP -ROT DUP io-base GPIO.CRL + OVER 8 AND 1 RSHIFT + >R ( R: crl/crh )
  io# 7 AND 4 * ( mode shift )
  0xF OVER LSHIFT INVERT ( mode shift mask )
  RSP@ @ AND -ROT LSHIFT OR SWAP  0xF AND DUP  7 > IF 8 - THEN
  4 * 0xF SWAP LSHIFT DUP ROT AND SWAP R> DUP @ ROT INVERT AND ROT OR SWAP ! ;

: io-modes! ( mode pin mask -- )  \ shorthAND to config multiple pins of a port
  16 0 DO
    I bit OVER AND IF
      >R  2DUP ( mode pin mode pin R: mask ) 0xF BIC I OR io-mode!  R>
    THEN
  LOOP 2DROP DROP ;

: io. ( pin -- )  \ display readable GPIO registers associated with a pin
  CR
  DECIMAL
    ." PIN " DUP io#  DUP .  10 < IF SPACE THEN
   ." PORT " HEX DUP io-port [CHAR] A + EMIT
   io-base
   BASE @
   HEX
   SWAP
  ."   CRL " DUP @ . 4 +
   ."  CRH " DUP @ . 4 +
   ."  IDR " DUP @ .  4 +
."   ODR " DUP @ . DROP BASE ! ;


!***********************************************************************
!                                                                      *
      SUBROUTINE GETMIXBLOCK(NAME, NCI)
!                                                                      *
!   Reads mixing coefficient file from block-structured format         *
!                                                                      *
!   Note:                                                              *
!   eav is not compatible with the non-block version if some blocks    *
!   were not diagonalized                                              *
!                                                                      *
!   This is a modified version of cvtmix.f                             *
!                                                                      *
!   Written by Per Jonsson,                           September 2003   *
!   Modified by G. Gaigalas,                                May 2011   *
!                                                                      *
!   Modified by C. Cychen                                       2021   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  18:32:57   1/ 6/07
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE memory_man
      USE def_C
      USE EIGV_C
      USE orb_C
      USE prnt_C
      USE syma_C
      USE iounit_C
      USE blk_C,            ONLY: NEVINBLK, NCFINBLK, TWO_J
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE openfl_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: NCI
      CHARACTER(LEN=24), INTENT(IN) :: NAME
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K, IERR, IOS, NCFTOT, NVECTOT, NVECSIZ, NBLOCK, I, NVECPAT, &
         NCFPAT, NEAVSUM, JB, NB, NCFBLK, NEVBLK, IATJP, IASPA, J
      REAL(DOUBLE) :: EAVSUM
      integer*8 NVECSIZPAT, NCFTOT_i8,NVECSIZ_i8
      CHARACTER(LEN=3)   :: STATUS
      CHARACTER(LEN=6)   :: G92MIX
      CHARACTER(LEN=11)  :: FORM
      CHARACTER(LEN=256) :: FILNAM
!-----------------------------------------------
!
!   The  .mix  file is UNFORMATTED; it must exist
!
      K = INDEX(NAME,' ')
      IF (NCI == 0) THEN
         FILNAM = NAME(1:K-1)//'.cm'
      ELSE
         FILNAM = NAME(1:K-1)//'.m'
      ENDIF
      FORM = 'UNFORMATTED'
      STATUS = 'OLD'
!
      CALL OPENFL (25, FILNAM, FORM, STATUS, IERR)
      IF (IERR == 1) THEN
         WRITE (ISTDE, *) 'Error when opening', FILNAM
         STOP
      ENDIF
!
!   Check the header of the file; if not as expected, try again
!
      READ (25, IOSTAT=IOS) G92MIX
      IF (IOS/=0 .OR. G92MIX/='G92MIX') THEN
         WRITE (ISTDE, *) 'Not a GRASP92 MIXing Coefficients File;'
         CLOSE(25)
         STOP
      ENDIF

      READ (25) NELEC, NCFTOT, NW, NVECTOT, NVECSIZ, NBLOCK
      WRITE (*, *) '   nelec  = ', NELEC
      WRITE (*, *) '   ncftot = ', NCFTOT
      WRITE (*, *) '   nw     = ', NW
      WRITE (*, *) '   nblock = ', NBLOCK
      WRITE (*, *)
      NCFTOT_i8 = NCFTOT

!***********************************************************************
! Allocate memory for old format data
!***********************************************************************

!GG      CALL ALLOC (EVAL, NVECTOT, 'EVAL', 'GETMIXBLOCK')
!GG      CALL ALLOC (EVEC, NCFTOT*NVECTOT, 'EVEC', 'GETMIXBLOCK')
!GG      CALL ALLOC (IVEC, NVECTOT, 'IVEC', 'GETMIXBLOCK')
!GG      CALL ALLOC (IATJPO, NVECTOT, 'IATJPO', 'GETMIXBLOCK')
!GG      CALL ALLOC (IASPAR, NVECTOT, 'IASPAR', 'GETMIXBLOCK')
      allocate (EVAL(NVECTOT))
      allocate (EVEC(NCFTOT_i8*NVECTOT))
      allocate (IVEC(NVECTOT))
      allocate (IATJPO(NVECTOT))
      allocate (IASPAR(NVECTOT))

!***********************************************************************
! Initialize mixing coefficients to zero; others are fine
!***********************************************************************
      EVEC(:NVECTOT*NCFTOT_i8) = 0.D0

!***********************************************************************
! Initialize counters and sum registers
!
!    nvecpat:    total number of eigenstates of the previous blocks
!    ncfpat:     total number of CSF of the previous blocks
!    nvecsizpat: vector size of the previous blocks
!    eavsum:     sum of diagonal elements of the previous blocks where
!                at least one eigenstate is calculated
!    neavsum:    total number CSF contributing to eavsum
!***********************************************************************

      NVECPAT = 0
      NCFPAT = 0
      NVECSIZPAT = 0
      NEAVSUM = 0
      EAVSUM = 0.D0

      WRITE (*, *) '  block     ncf     nev    2j+1  parity'
      DO JB = 1, NBLOCK

         READ (25) NB, NCFBLK, NEVBLK, IATJP, IASPA
         WRITE (*, '(5I8)') NB, NCFBLK, NEVBLK, IATJP, IASPA
         NEVINBLK(JB) = NEVBLK
         NCFINBLK(JB) = NCFBLK
         TWO_J(JB) = IATJP - 1
         IF (JB /= NB) STOP 'jb .NE. nb'

         IF (NEVBLK > 0) THEN

            READ (25) (IVEC(NVECPAT + I),I=1,NEVBLK)
               ! ivec(i)   = ivec(i) + ncfpat ! serial # of the state
            IATJPO(NVECPAT+1:NEVBLK+NVECPAT) = IATJP
            IASPAR(NVECPAT+1:NEVBLK+NVECPAT) = IASPA

            READ (25) EAV, (EVAL(NVECPAT+I),I=1,NEVBLK)

!           ...Construct the true energy by adding up the average
            EVAL(NVECPAT+1:NEVBLK+NVECPAT) = EVAL(NVECPAT+1:NEVBLK+NVECPAT) + &
               EAV
!           ...For overal (all blocks) average energy
            EAVSUM = EAVSUM + EAV*NCFBLK
            NEAVSUM = NEAVSUM + NCFBLK

            READ (25) ((EVEC(NVECSIZPAT+NCFPAT+I+(J-1)*NCFTOT_i8),I=1,NCFBLK),J=1,&
               NEVBLK)
         ENDIF
!
         NVECPAT = NVECPAT + NEVBLK
         NCFPAT = NCFPAT + NCFBLK
         NVECSIZPAT = NVECSIZPAT + NEVBLK*NCFTOT_i8
!
      END DO

!     ...Here eav is the average energy of the blocks where at least
!        one eigenstate is calculated. It is not the averge of the
!        total Hamiltonian.

      EAV = EAVSUM/NEAVSUM

      IF (NCFTOT /= NEAVSUM) WRITE (6, *) &
         'Not all blocks are diagonalized --- Average E ', 'not correct'

!     ...Substrct the overal average energy
      EVAL(:NVECTOT) = EVAL(:NVECTOT) - EAV
!
      CLOSE(25)
!
      NCF = NCFTOT
      NVEC = NVECTOT
!
      RETURN
      END SUBROUTINE GETMIXBLOCK