!-------------------------------------------------------------------------------
!> module OCEAN / Physics
!!
!! @par Description
!!          ocean physics module
!!
!! @author Team SCALE
!!
!<
!-------------------------------------------------------------------------------
module mod_ocean_phy_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_debug
  use scale_grid_index

  use scale_const, only: &
     I_SW  => CONST_I_SW, &
     I_LW  => CONST_I_LW
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: OCEAN_PHY_driver_setup
  public :: OCEAN_PHY_driver

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !> Setup
  subroutine OCEAN_PHY_driver_setup
    use scale_ocean_phy, only: &
       OCEAN_PHY_setup
    use scale_ocean_sfc, only: &
       OCEAN_SFC_setup
    use mod_admin_restart, only: &
       RESTART_RUN
    use mod_ocean_admin, only: &
       OCEAN_TYPE, &
       OCEAN_sw
    implicit none
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '++++++ Module[DRIVER] / Categ[OCEAN PHY] / Origin[SCALE-LES]'

    if ( OCEAN_sw ) then

       ! setup library component
       call OCEAN_PHY_setup( OCEAN_TYPE )
       call OCEAN_SFC_setup( OCEAN_TYPE )

       if( .NOT. RESTART_RUN ) then
          ! run once (only for the diagnostic value)
          call PROF_rapstart('OCN_Physics', 1)
          call OCEAN_PHY_driver( update_flag = .true. )
          call PROF_rapend  ('OCN_Physics', 1)
       else
          ! no update in order to use restart value
       end if

    else
       if( IO_L ) write(IO_FID_LOG,*) '*** this component is never called.'
    endif

    return
  end subroutine OCEAN_PHY_driver_setup

  !-----------------------------------------------------------------------------
  !> Driver
  subroutine OCEAN_PHY_driver( update_flag )
    use scale_atmos_thermodyn, only: &
       ATMOS_THERMODYN_templhv
    use scale_time, only: &
       dt => TIME_DTSEC_OCEAN
    use scale_les_statistics, only: &
       STATISTICS_checktotal, &
       STAT_total
    use scale_history, only: &
       HIST_in
    use scale_grid_real, only: &
       REAL_Z1
    use scale_roughness, only: &
       ROUGHNESS
    use scale_ocean_phy, only: &
       OCEAN_PHY
    use scale_ocean_sfc, only: &
       OCEAN_SFC,              &
       OCEAN_SFC_SimpleAlbedo
    use mod_ocean_vars, only: &
       OCEAN_TEMP,         &
       OCEAN_SFC_TEMP,     &
       OCEAN_SFC_albedo,   &
       OCEAN_SFC_Z0M,      &
       OCEAN_SFC_Z0H,      &
       OCEAN_SFC_Z0E,      &
       OCEAN_TEMP_t,       &
       OCEAN_SFC_TEMP_t,   &
       OCEAN_SFC_albedo_t, &
       OCEAN_SFC_Z0M_t,    &
       OCEAN_SFC_Z0H_t,    &
       OCEAN_SFC_Z0E_t,    &
       OCEAN_SFLX_MW,      &
       OCEAN_SFLX_MU,      &
       OCEAN_SFLX_MV,      &
       OCEAN_SFLX_SH,      &
       OCEAN_SFLX_LH,      &
       OCEAN_SFLX_WH,      &
       OCEAN_SFLX_evap,    &
       OCEAN_U10,          &
       OCEAN_V10,          &
       OCEAN_T2,           &
       OCEAN_Q2,           &
       ATMOS_TEMP,         &
       ATMOS_PRES,         &
       ATMOS_W,            &
       ATMOS_U,            &
       ATMOS_V,            &
       ATMOS_DENS,         &
       ATMOS_QV,           &
       ATMOS_PBL,          &
       ATMOS_SFC_PRES,     &
       ATMOS_SFLX_LW,      &
       ATMOS_SFLX_SW,      &
       ATMOS_cosSZA,       &
       ATMOS_SFLX_prec
    implicit none

    logical, intent(in) :: update_flag

    real(RP) :: total ! dummy
    real(RP) :: lhv(IA,JA)

    integer  :: i, j
    !---------------------------------------------------------------------------

    if ( update_flag ) then

       call ROUGHNESS( OCEAN_SFC_Z0M_t(:,:), & ! [OUT]
                       OCEAN_SFC_Z0H_t(:,:), & ! [OUT]
                       OCEAN_SFC_Z0E_t(:,:), & ! [OUT]
                       OCEAN_SFC_Z0M  (:,:), & ! [IN]
                       OCEAN_SFC_Z0H  (:,:), & ! [IN]
                       OCEAN_SFC_Z0E  (:,:), & ! [IN]
                       ATMOS_U        (:,:), & ! [IN]
                       ATMOS_V        (:,:), & ! [IN]
                       REAL_Z1        (:,:), & ! [IN]
                       dt                    ) ! [IN]

       call OCEAN_SFC_SimpleAlbedo( OCEAN_SFC_albedo_t(:,:,:), & ! [OUT]
                                    OCEAN_SFC_albedo  (:,:,:), & ! [IN]
                                    ATMOS_cosSZA      (:,:),   & ! [IN]
                                    dt                         ) ! [IN]

       call OCEAN_SFC( OCEAN_SFC_TEMP_t(:,:),      & ! [OUT]
                       OCEAN_SFLX_MW   (:,:),      & ! [OUT]
                       OCEAN_SFLX_MU   (:,:),      & ! [OUT]
                       OCEAN_SFLX_MV   (:,:),      & ! [OUT]
                       OCEAN_SFLX_SH   (:,:),      & ! [OUT]
                       OCEAN_SFLX_LH   (:,:),      & ! [OUT]
                       OCEAN_SFLX_WH   (:,:),      & ! [OUT]
                       OCEAN_U10       (:,:),      & ! [OUT]
                       OCEAN_V10       (:,:),      & ! [OUT]
                       OCEAN_T2        (:,:),      & ! [OUT]
                       OCEAN_Q2        (:,:),      & ! [OUT]
                       ATMOS_TEMP      (:,:),      & ! [IN]
                       ATMOS_PRES      (:,:),      & ! [IN]
                       ATMOS_W         (:,:),      & ! [IN]
                       ATMOS_U         (:,:),      & ! [IN]
                       ATMOS_V         (:,:),      & ! [IN]
                       ATMOS_DENS      (:,:),      & ! [IN]
                       ATMOS_QV        (:,:),      & ! [IN]
                       REAL_Z1         (:,:),      & ! [IN]
                       ATMOS_PBL       (:,:),      & ! [IN]
                       ATMOS_SFC_PRES  (:,:),      & ! [IN]
                       ATMOS_SFLX_LW   (:,:),      & ! [IN]
                       ATMOS_SFLX_SW   (:,:),      & ! [IN]
                       OCEAN_TEMP      (:,:),      & ! [IN]
                       OCEAN_SFC_TEMP  (:,:),      & ! [IN]
                       OCEAN_SFC_albedo(:,:,I_LW), & ! [IN]
                       OCEAN_SFC_albedo(:,:,I_SW), & ! [IN]
                       OCEAN_SFC_Z0M   (:,:),      & ! [IN]
                       OCEAN_SFC_Z0H   (:,:),      & ! [IN]
                       OCEAN_SFC_Z0E   (:,:),      & ! [IN]
                       dt                          ) ! [IN]

       call ATMOS_THERMODYN_templhv( lhv, ATMOS_TEMP )

!OCL XFILL
       do j = JS, JE
       do i = IS, IE
          OCEAN_SFLX_evap(i,j) = OCEAN_SFLX_LH(i,j) / lhv(i,j)
       end do
       end do

       call OCEAN_PHY( OCEAN_TEMP_t   (:,:), & ! [OUT]
                       OCEAN_TEMP     (:,:), & ! [IN]
                       OCEAN_SFLX_WH  (:,:), & ! [IN]
                       ATMOS_SFLX_prec(:,:), & ! [IN]
                       OCEAN_SFLX_evap(:,:), & ! [IN]
                       dt                    ) ! [IN]

       call HIST_in( OCEAN_TEMP_t      (:,:),      'OCEAN_TEMP_t',     'tendency of OCEAN_TEMP',     'K'   )
       call HIST_in( OCEAN_SFC_TEMP_t  (:,:),      'OCEAN_SFC_TEMP_t', 'tendency of OCEAN_SFC_TEMP', 'K'   )
       call HIST_in( OCEAN_SFC_albedo_t(:,:,I_LW), 'OCEAN_ALB_LW_t',   'tendency of OCEAN_ALB_LW',   '0-1' )
       call HIST_in( OCEAN_SFC_albedo_t(:,:,I_SW), 'OCEAN_ALB_SW_t',   'tendency of OCEAN_ALB_SW',   '0-1' )
       call HIST_in( OCEAN_SFC_Z0M_t   (:,:),      'OCEAN_SFC_Z0M_t',  'tendency of OCEAN_SFC_Z0M',  'm'   )
       call HIST_in( OCEAN_SFC_Z0H_t   (:,:),      'OCEAN_SFC_Z0H_t',  'tendency of OCEAN_SFC_Z0H',  'm'   )
       call HIST_in( OCEAN_SFC_Z0E_t   (:,:),      'OCEAN_SFC_Z0E_t',  'tendency of OCEAN_SFC_Z0E',  'm'   )

    end if

    if ( STATISTICS_checktotal ) then
       call STAT_total( total, OCEAN_TEMP_t      (:,:),      'OCEAN_TEMP_t'     )
       call STAT_total( total, OCEAN_SFC_TEMP_t  (:,:),      'OCEAN_SFC_TEMP_t' )
       call STAT_total( total, OCEAN_SFC_albedo_t(:,:,I_LW), 'OCEAN_ALB_LW_t'   )
       call STAT_total( total, OCEAN_SFC_albedo_t(:,:,I_SW), 'OCEAN_ALB_SW_t'   )
       call STAT_total( total, OCEAN_SFC_Z0M_t   (:,:),      'OCEAN_SFC_Z0M_t'  )
       call STAT_total( total, OCEAN_SFC_Z0H_t   (:,:),      'OCEAN_SFC_Z0H_t'  )
       call STAT_total( total, OCEAN_SFC_Z0E_t   (:,:),      'OCEAN_SFC_Z0E_t'  )
    end if

    return
  end subroutine OCEAN_PHY_driver

end module mod_ocean_phy_driver


subroutine qm3_lio_init
    use garcha_mod, only: ntatom, natom, nsol, Iz, mulliken, writeforces, writexyz
    use fileio_data, only: verbose

    implicit none
    integer :: ierr
    character(len=20) :: inpfile

    call lio_defaults()
    writexyz = .false.
    inpfile = "lio.inp"
    call read_options(inpfile, ierr)
    inpfile = "lio.xyz"
    verbose = 0
    mulliken = .false.
    writeforces = .false.
    call read_coords( inpfile )
    call init_lio_common( natom, Iz, nsol, 0 )
end subroutine qm3_lio_init

subroutine qm3_lio_calc( siz, dat )
    use garcha_mod, only: ntatom, natom, nsol, Smat, RealRho, sqsm, &
                           Eorbs, Eorbs_b, d, r, Iz, Em, Rm, pc, rqm, Pmat_vec
    use basis_data, only: M, MM, Nuc
    use faint_cpu, only: int1
    use SCF_aux, only: fix_densmat
    implicit none
    integer, intent( in ) :: siz
    real*8, dimension(0:siz-1), intent( inout ) :: dat

    real*8, dimension(:,:), allocatable :: qm_grd, mm_grd
    real*8, dimension(:), allocatable :: qm_chg, Fock_1e, Hmat
    real*8 :: ene, tmp
    integer :: i, j, k

    if( .not. allocated( Smat ) )    allocate( Smat(M,M) )
    if( .not. allocated( RealRho ) ) allocate( RealRho(M,M) )
    if( .not. allocated( sqsm ) )    allocate( sqsm(M,M) )
    if( .not. allocated( Eorbs ) )   allocate( Eorbs(M) )
    if( .not. allocated( Eorbs_b ) ) allocate( Eorbs_b(M) )

    allocate( qm_chg(1:natom), qm_grd(1:3,1:natom) )
    if( nsol > 0 ) allocate( mm_grd(1:3,1:nsol) )

    k = 0
    do i = 1, natom
        do j = 1, 3
            r(i,j)   = dat(k) / 0.529177d0
            rqm(i,j) = dat(k) / 0.529177d0
            k = k + 1
        end do
    end do
    do i = 1, nsol
        do j = 1, 3
            r(natom+i,j) = dat(k) / 0.529177d0
            k = k + 1
        end do
    end do

    call recenter_coords( rqm, r, natom, nsol )

    call SCF( ene )

    allocate( Fock_1e(1:MM), Hmat(1:MM) )
    call int1( tmp, Fock_1e, Hmat, Smat, d, r, Iz, natom, ntatom )
    call spunpack( 'L', M, Fock_1e, Smat )
    call spunpack( 'L', M, Pmat_vec(1), RealRho )
    deallocate( Fock_1e, Hmat )
    call fix_densmat( RealRho )
    do i = 1, natom
         qm_chg(i) = real( Iz(i), kind=8 )
    enddo
    call mulliken_calc( natom, M, RealRho, Smat, Nuc, qm_chg )

    call dft_get_qm_forces( qm_grd )
    if( nsol > 0 ) call dft_get_mm_forces( mm_grd, qm_grd )

    dat(0) = ene
    do i = 1, natom
        dat(i) = qm_chg( i )
    end do
    do i = 1, natom
        j = 1 + natom + ( i - 1 ) * 3
        dat(j)   = qm_grd(1,i)
        dat(j+1) = qm_grd(2,i)
        dat(j+2) = qm_grd(3,i)
    end do
    do i = 1, nsol
        j = 1 + 4 * natom + ( i - 1 ) * 3
        dat(j)   = mm_grd(1,i)
        dat(j+1) = mm_grd(2,i)
        dat(j+2) = mm_grd(3,i)
    end do

    deallocate( qm_chg, qm_grd )
    if( nsol > 0 ) deallocate( mm_grd )
end subroutine qm3_lio_calc

subroutine qm3_lio_clean
    call lio_finalize()
end subroutine qm3_lio_clean


      subroutine kbppv3(psp_filename,formatted_filename,
     >                  nfft1,nfft2,nfft3,unita)
*
* $Id$
*
      implicit none

      character*50     psp_filename,formatted_filename
      integer          nfft1,nfft2,nfft3
      double precision unita(3,3)

      integer nrmax
      double precision vp(NRMAX,0:3)
      double precision wp(NRMAX,0:3)
      double precision rho(nrmax)

      double precision vl(nfft1/2+1,nfft2,nfft3)
      double precision vnl(nfft1/2+1,nfft2,nfft3,9)
      double precision G(nfft1/2+1,nfft2,nfft3,3)

      double precision vnlnrm(9)
      double precision unitg(3,3)
      double precision rc(0:4)

      character*2 atom

*     pseudopotential data
      OPEN(UNIT=11,FILE=psp_filename,STATUS='OLD',FORM='FORMATTED')
      READ(11,'(A2)',ERR=9116,END=9117) ATOM
      READ(11,*,ERR=9116,END=9117) ZV,AMASS,LMAX
      READ(11,*,ERR=9116,END=9117) (RC(I),I=0,LMAX)
      READ(11,*,ERR=9116,END=9117) NRHO,DRHO
      IF(NRHO.GT.NRMAX) THEN
        IERR=3
        GO TO 9999
      ENDIF
      READ(11,*,ERR=9116,END=9117)(RHO(I),(VP(I,J),J=0,LMAX),I=1,NRHO)
      READ(11,*,ERR=9116,END=9117)(RHO(I),(WP(I,J),J=0,LMAX),I=1,NRHO)
      CLOSE(11)

      WRITE(*,'(A,I1)') 'Lmax = ',LMAX
      WRITE(*,'(a,$)') "enter the highest L desired =>"
      READ(*,*) LMAX0
      LMAX=MIN(LMAX,LMAX0)

*     preparation of constants
      CALL SETUP(IERR)
      IF(IERR.NE.0) THEN
        IERR=IERR+100
        GO TO 9999
      ENDIF

      CALL KBPP(IERR)
      IF(IERR.NE.0) THEN
        IERR=IERR+200
        GO TO 9999
      ENDIF

      l = indx(formatted_filename,' ') - 1
      call openfile(6,formatted_filename,'w',l)
         call iwrite(6,nfft1,1)
         call iwrite(6,nfft2,1)
         call iwrite(6,nfft3,1)
         call dwrite(6,unita,9)
         call cwrite(6,atom,2)
         call dwrite(6,amass,1)
         call dwrite(6,zv,1)
         call iwrite(6,lmax,1)
         call dwrite(6,rc,lmax+1)
         call dwrite(6,vnlnrm,lmmax)
         call dwrite(6,vl,(nfft1/2+1)*nfft2*nfft3)
         call dwrite(6,vnl,(nfft1/2+1)*nfft2*nfft3*lmmax)
      call closefile(6)

      IERR=0
      GO TO 9999

 9110 IERR=10
      GO TO 9999
 9111 IERR=11
      GO TO 9999
 9116 IERR=16
      GO TO 9999
 9117 IERR=17
      GO TO 9999

 9999 IF(IERR.EQ.0) THEN
        WRITE(6,*) ' JOB HAS BEEN COMPLETED.  CODE=',IERR
      ELSE
        WRITE(6,*) ' JOB HAS BEEN TERMINATED DUE TO CODE=',IERR
      ENDIF
      STOP
      END


! Copyright (C) 2001-2011 Quantum ESPRESSO group
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
! or http://www.gnu.org/copyleft/gpl.txt .
!
!
!----------------------------------------------------------------------------
SUBROUTINE c_bands( iter, ik_, dr2 )
  !----------------------------------------------------------------------------
  !
  ! ... Driver routine for Hamiltonian diagonalization routines
  ! ... It reads the Hamiltonian and an initial guess of the wavefunctions
  ! ... from a file and computes initialization quantities for the
  ! ... diagonalization routines.
  !
  USE kinds,                ONLY : DP
  USE io_global,            ONLY : stdout
  USE io_files,             ONLY : iunigk, nwordatwfc, iunsat, iunwfc, &
                                   nwordwfc
  USE buffers,              ONLY : get_buffer, save_buffer
  USE klist,                ONLY : nkstot, nks, xk, ngk
  USE uspp,                 ONLY : vkb, nkb
  USE gvect,                ONLY : g
  USE wvfct,                ONLY : et, nbnd, npwx, igk, npw, current_k
  USE control_flags,        ONLY : ethr, isolve, io_level
  USE lsda_mod,             ONLY : current_spin, lsda, isk
  USE wavefunctions_module, ONLY : evc
  USE mp_global,            ONLY : inter_pool_comm
  USE mp,                   ONLY : mp_sum
  !
  IMPLICIT NONE
  !
  ! ... First the I/O variables
  !
  INTEGER :: ik_, iter
  ! k-point already done
  ! current iterations
  REAL(DP),INTENT(IN) :: dr2
  ! current accuracy of self-consistency
  !
  ! ... local variables
  !
  REAL(DP) :: avg_iter
  ! average number of H*psi products
  INTEGER :: ik
  ! counter on k points
  !
  IF ( ik_ == nks ) THEN
     !
     ik_ = 0
     !
     RETURN
     !
  END IF
  !
  CALL start_clock( 'c_bands' )
  !
  IF ( isolve == 0 ) THEN
     !
     WRITE( stdout, '(5X,"Davidson diagonalization with overlap")' )
     !
  ELSE IF ( isolve == 1 ) THEN
     !
     WRITE( stdout, '(5X,"CG style diagonalization")')
     !
  ELSE
     !
     CALL errore ( 'c_bands', 'invalid type of diagonalization', isolve)
     !!! WRITE( stdout, '(5X,"DIIS style diagonalization")')
     !
  END IF
  !
  avg_iter = 0.D0
  !
#ifdef __IGKIO
  if ( nks > 1 ) REWIND( iunigk )  !BMA: eliminate fs activity for miniDFT
#endif
  !
  ! ... For each k point diagonalizes the hamiltonian
  !
  k_loop: DO ik = 1, nks
     !
     current_k = ik
     !
     IF ( lsda ) current_spin = isk(ik)
     !
     ! ... Reads the list of indices k+G <-> G of this k point
     !
#ifdef __IGKIO
     IF ( nks > 1 ) READ( iunigk ) igk !BMA: eliminate fs activity for miniDFT
#endif
     !
     npw = ngk(ik)
     !
     ! ... do not recalculate k-points if restored from a previous run
     !
     IF ( ik <= ik_ ) THEN
        !
        CYCLE k_loop
        !
     END IF
     !
     ! ... various initializations
     !
     IF ( nkb > 0 ) CALL init_us_2( npw, igk, xk(1,ik), vkb )
     !
     ! ... kinetic energy
     !
     call g2_kin( ik )
     !
     ! ... read in wavefunctions from the previous iteration
     !
#ifdef __IGKIO
     IF ( nks > 1 .OR. (io_level > 1) ) &
          CALL get_buffer ( evc, nwordwfc, iunwfc, ik )
#endif
     ! ... Needed for LDA+U
     !
     !
     ! ... diagonalization of bands for k-point ik
     !
     call diag_bands ( iter, ik, avg_iter )
     !
     ! ... save wave-functions to be used as input for the
     ! ... iterative diagonalization of the next scf iteration
     ! ... and for rho calculation
     !
#ifdef __IGKIO
     IF ( nks > 1 .OR. (io_level > 1) ) &
          CALL save_buffer ( evc, nwordwfc, iunwfc, ik )
#endif
     ! ... save restart information
     !
     IF ( io_level > 1 ) CALL save_in_cbands( iter, ik, dr2 )
     !
  END DO k_loop
  !
  ik_ = 0
  !
  CALL mp_sum( avg_iter, inter_pool_comm )
  !
  avg_iter = avg_iter / nkstot
  !
  WRITE( stdout, &
       '( 5X,"ethr = ",1PE9.2,",  avg # of iterations =",0PF5.1 )' ) &
       ethr, avg_iter
  !
  CALL stop_clock( 'c_bands' )
  !
  RETURN
  !
END SUBROUTINE c_bands
!
!----------------------------------------------------------------------------
SUBROUTINE diag_bands( iter, ik, avg_iter )
  !----------------------------------------------------------------------------
  !
  ! ... Driver routine for diagonalization at each k-point
  ! ... Two types of iterative diagonalizations are currently used:
  ! ... a) Davidson algorithm (all-band)
  ! ... b) Conjugate Gradient (band-by-band)
  ! ...
  ! ... internal procedures :
  !
  ! ... c_bands_gamma()   : optimized algorithms for gamma sampling of the BZ
  ! ...                     (real Hamiltonian)
  ! ... c_bands_k()       : general algorithm for arbitrary BZ sampling
  ! ...                     (complex Hamiltonian)
  ! ... test_exit_cond()  : the test on the iterative diagonalization
  !
  !
  USE kinds,                ONLY : DP
  USE io_global,            ONLY : stdout
  USE io_files,             ONLY : nwordwfc, iunefieldp, iunefieldm
  USE uspp,                 ONLY : vkb, nkb, okvan
  USE gvect,                ONLY : gstart
  USE wvfct,                ONLY : g2kin, nbndx, et, nbnd, npwx, npw, &
       current_k, btype
  USE control_flags,        ONLY : ethr, lscf, max_cg_iter, isolve, istep
  USE wavefunctions_module, ONLY : evc
  USE g_psi_mod,            ONLY : h_diag, s_diag
  USE scf,                  ONLY : v_of_0
  USE becmod,               ONLY : bec_type, becp, calbec, &
                                   allocate_bec_type, deallocate_bec_type
  USE klist,                ONLY : nks
  USE mp_global,            ONLY : nproc_bgrp, intra_bgrp_comm
  !
  IMPLICIT NONE
  !
  integer, parameter :: npol=1 !substitute for noncollin_module%npol
  INTEGER, INTENT(IN)  :: iter, ik
  !
  REAL (KIND=DP), INTENT(INOUT) :: avg_iter
  !
  REAL (KIND=DP) :: cg_iter
  ! (weighted) number of iterations in Conjugate-Gradient
  INTEGER :: ig, dav_iter, ntry, notconv
  ! number of iterations in Davidson
  ! number or repeated call to diagonalization in case of non convergence
  ! number of notconverged elements
  INTEGER :: ierr
  !
  LOGICAL :: lrot
  ! .TRUE. if the wfc have already be rotated
  !
  ALLOCATE( h_diag( npwx, npol ), STAT=ierr )
  IF( ierr /= 0 ) &
     CALL errore( ' diag_bands ', ' cannot allocate h_diag ', ABS(ierr) )
  !
  ALLOCATE( s_diag( npwx, npol ), STAT=ierr )
  IF( ierr /= 0 ) &
     CALL errore( ' diag_bands ', ' cannot allocate s_diag ', ABS(ierr) )
  !
  ! ... allocate space for <beta_i|psi_j> - used in h_psi and s_psi
  !
  IF ( nbndx > npwx*nproc_bgrp ) &
     CALL errore ( 'diag_bands', 'too many bands, or too few plane waves',1)
  !
  CALL allocate_bec_type ( nkb, nbnd, becp, intra_bgrp_comm )
  !
     !
     CALL c_bands_k()
     !
  !
  ! ... deallocate work space
  !
  CALL deallocate_bec_type ( becp )
  DEALLOCATE( s_diag )
  DEALLOCATE( h_diag )
  !
  IF ( notconv > MAX( 5, nbnd / 4 ) ) THEN
     !
     CALL errore( 'c_bands', &
          & 'too many bands are not converged', 1 )
     !
  ELSE IF ( notconv > 0 ) THEN
     !
     WRITE( stdout, '(5X,"c_bands: ",I2, &
               &   " eigenvalues not converged")' ) notconv
     !
  END IF
  !
  RETURN
  !
CONTAINS
  !
  ! ... internal procedures
  !
  !-----------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------
  SUBROUTINE c_bands_k()
    !-----------------------------------------------------------------------
    !
    ! ... Complex Hamiltonian diagonalization
    !
    IMPLICIT NONE
    !
    ! ... here the local variables
    !
    INTEGER :: ipol, ierr
    !
    !
    IF ( isolve == 1 ) THEN
       !
       ! ... Conjugate-Gradient diagonalization
       !
       ! ... h_diag is the precondition matrix
       !
       h_diag = 1.D0
       !
       FORALL( ig = 1 : npwx )
          !
          h_diag(ig,:) = 1.D0 + g2kin(ig) + &
             SQRT( 1.D0 + ( g2kin(ig) - 1.D0 )**2 )
          !
       END FORALL
       !
       ntry = 0
       !
       CG_loop : DO
          !
          lrot = ( iter == 1 .AND. istep ==0 .AND. ntry == 0 )
          !
          IF ( .NOT. lrot ) THEN
             !
             CALL rotate_wfc ( npwx, npw, nbnd, gstart, nbnd, &
                               evc, npol, okvan, evc, et(1,ik) )
             !
             avg_iter = avg_iter + 1.D0
             !
          END IF
          !
          CALL ccgdiagg( npwx, npw, nbnd, npol, evc, et(1,ik), btype(1,ik), &
               h_diag, ethr, max_cg_iter, .NOT. lscf, notconv, cg_iter )
          !
          avg_iter = avg_iter + cg_iter
          !
          ntry = ntry + 1
          !
          ! ... exit condition
          !
          IF ( test_exit_cond() ) EXIT  CG_loop
          !
       END DO CG_loop
       !
    ELSE
       !
       ! ... Davidson diagonalization
       !
       ! ... h_diag are the diagonal matrix elements of the
       ! ... hamiltonian used in g_psi to evaluate the correction
       ! ... to the trial eigenvectors
       !
       DO ipol = 1, npol
          !
          h_diag(1:npw, ipol) = g2kin(1:npw) + v_of_0
          !
       END DO
       !
       CALL usnldiag( h_diag, s_diag )
       !
       ntry = 0
       !
       david_loop: DO
          !
          lrot = ( iter == 1 )
          !
             !
             CALL pcegterg( npw, npwx, nbnd, nbndx, npol, evc, ethr, &
                         okvan, et(1,ik), btype(1,ik), &
                         notconv, lrot, dav_iter )
          !
          avg_iter = avg_iter + dav_iter
          !
          ! ... save wave-functions to be used as input for the
          ! ... iterative diagonalization of the next scf iteration
          ! ... and for rho calculation
          !
          ntry = ntry + 1
          !
          ! ... exit condition
          !
          IF ( test_exit_cond() ) EXIT david_loop
          !
       END DO david_loop
       !
    END IF
    !
    !
    RETURN
    !
  END SUBROUTINE c_bands_k
  !
  !-----------------------------------------------------------------------
  FUNCTION test_exit_cond()
    !-----------------------------------------------------------------------
    !
    ! ... this logical function is .TRUE. when iterative diagonalization
    ! ... is converged
    !
    IMPLICIT NONE
    !
    LOGICAL :: test_exit_cond
    !
    !
    test_exit_cond = .NOT. ( ( ntry <= 5 ) .AND. &
         ( ( .NOT. lscf .AND. ( notconv > 0 ) ) .OR. &
         (       lscf .AND. ( notconv > 5 ) ) ) )
    !
  END FUNCTION test_exit_cond
  !
END SUBROUTINE diag_bands
!


cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYFRAM
C...Performs transformations between different coordinate frames.

      SUBROUTINE PYFRAM(IFRAME)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Commonblocks.
      include 'inc/pydat1'
      include 'inc/pypars'
      include 'inc/pyint1'

C...Check that transformation can and should be done.
      IF(IFRAME.EQ.1.OR.IFRAME.EQ.2.OR.(IFRAME.EQ.3.AND.
     &MINT(91).EQ.1)) THEN
        IF(IFRAME.EQ.MINT(6)) RETURN
      ELSE
        WRITE(MSTU(11),5000) IFRAME,MINT(6)
        RETURN
      ENDIF

      IF(MINT(6).EQ.1) THEN
C...Transform from fixed target or user specified frame to
C...overall CM frame.
        CALL PYROBO(0,0,0D0,0D0,-VINT(8),-VINT(9),-VINT(10))
        CALL PYROBO(0,0,0D0,-VINT(7),0D0,0D0,0D0)
        CALL PYROBO(0,0,-VINT(6),0D0,0D0,0D0,0D0)
      ELSEIF(MINT(6).EQ.3) THEN
C...Transform from hadronic CM frame in DIS to overall CM frame.
        CALL PYROBO(0,0,-VINT(221),-VINT(222),-VINT(223),-VINT(224),
     &  -VINT(225))
      ENDIF

      IF(IFRAME.EQ.1) THEN
C...Transform from overall CM frame to fixed target or user specified
C...frame.
        CALL PYROBO(0,0,VINT(6),VINT(7),VINT(8),VINT(9),VINT(10))
      ELSEIF(IFRAME.EQ.3) THEN
C...Transform from overall CM frame to hadronic CM frame in DIS.
        CALL PYROBO(0,0,0D0,0D0,VINT(223),VINT(224),VINT(225))
        CALL PYROBO(0,0,0D0,VINT(222),0D0,0D0,0D0)
        CALL PYROBO(0,0,VINT(221),0D0,0D0,0D0,0D0)
      ENDIF

C...Set information about new frame.
      MINT(6)=IFRAME
      MSTI(6)=IFRAME

 5000 FORMAT(1X,'Error: illegal values in subroutine PYFRAM.',1X,
     &'No transformation performed.'/1X,'IFRAME =',1X,I5,'; MINT(6) =',
     &1X,I5)

      RETURN
      END


      program fieldproc
      use mod_plot  ! HYCOM plot array interface
      use mod_za    ! HYCOM array I/O interface
c
c --- 2-D horizontal field plot processor
c
c --- Use environment variable OVERLAY to control overlay
c ---   if OVERLAY is "CONTOUR" then overlay a 2nd field as a line contour
c ---   if OVERLAY is "VECTOR"  then overlay a vector field
c ---   if OVERLAY is "VECCONT" then overlay a vector and scaler field
c ---   if OVERLAY is "VECBATH" then overlay a vector field and bathymetry
c ---   "CONTOUR_NL" and "VEC????_NL" turn off labeling of line contours.
c ---   Replace VEC with ENVEC for eastward,northward vector input.  The
c ---    default is xward,yward vector input, and for completeness XYVEC
c ---    is also allowed.  Note that the archv2* programs write out
c ---    eastward,northward currents by default, and that the two are
c ---    identical on rectilinear grids (with pang identically zero).
c
c --- Use environment variable PLOT_MASKED to control masked sea regions
c ---   if PLOT_MASKED is "YES" or "yes" then contour them in gray
c
c --- Use environment variable TRACKS or TRACKS_XY to (optionally) identify
c --- a file of locations to mark, and/or tracks to draw, on the plot.
c --- TRACKS contains lon,lat locations, and TRACKS_XY contains array
c --- locations.  Specify only one of TRACKS or TRACKS_XY.
c --- Note that specifying array locations will be significantly faster
c --- than lon,lat locations for curvi-linear domains, but they are w.r.t.
c --- the plotted subregion and should therefore be used with caution.
c --- Use hycom_lonlat2xy to convert lon,lat to x,y on the original
c --- array, and hycom_subset_xy to convert these to the plotted subregion.
c --- For more information, see tracks.f.
c
c --- Use environment variable ARROW_UNITS for vector units (default "cm/s")
c --- Use environment variable ARROW_XEDGE for minimum x edge (default 1.0)
c --- Use environment variable ARROW_YEDGE for minimum y edge (default 1.0)
c --- Use environment variable ARROW_PLTHICK   for polyline thickness
c --- Use environment variable ARROW_PLCOLOR   for polyline color
c --- Use environment variable CONTOUR_PLTHICK for polyline thickness
c --- Use environment variable CONTOUR_PLCOLOR for polyline color
c
      real, allocatable :: work(:,:)
      real, allocatable :: ufield(:,:),vfield(:,:),fieldm(:,:)
c
      common/conrng/ amn,amx
c
      character plabel*80,region*12
      character flnm*240,flnm2*240,flnmv*240,flnmu*240,flnmtr*240
      character line_new*240
      character text*24,text1*10,text2*10,text3*10,cunits*12
c
      logical          ltrack,ltrack_xy,kpalet_neg,kpalet_cen,
     &                 lmskplt,xyward
      integer          artype,iexpt,kkin,yrflag,
     &                 kpalet,mxlflg,kover,lpalet,gray,
     &                 plindexc,plindexv
      double precision dt,dt0,time3(3),time,year
      real             grdlat,grdlon,pntlat,pntlon,reflat,
     &                 plthickc,plthickv
c
c --- spval  = data void marker, 2^100 or about 1.2676506e30
      real*4     spval
      parameter (spval=2.0**100)
c
      data flag/-.03125/,nquad/0/,ncount/0/
      character blank*40
      data blank/'                                        '/
      common/perframe/nperfr,locbar
c
c --- color options (see colors.f for a complete list).
c --- ipalet = 0      --  contour lines only, no color
c --- ipalet = 1      --  alternate pastel or one-sign (-ve or +ve) gray
c --- ipalet = 2      --  use canonical sst color palette  ( 64 intervals)
c --- ipalet = 3      --  use rainer's gaudy color palette (100 intervals)
c --- ipalet = 4      --  two-tone shades                  ( 64 intervals)
c --- ipalet = 5      --  NRL's 100 false color palette    (100 intervals)
c --- ipalet = 6      --  NRL's inverted 100 fc palette    (100 intervals)
c --- ipalet = 7      --  MATLAB's JET   BlCyYeRe          ( 20 intervals)
c --- ipalet = 8      --  MATLAB's JETw  BlCyWhYeRe        ( 20 intervals)
c --- ipalet = 9      --  MATLAB's JETww BlCyWhWhYeRe      ( 20 intervals)
c --- ipalet =10      --  MATLAB's JETw  BlCyWhYeRe        (100 intervals)
c --- ipalet =11      --  NCL's WhViBlGrYeOrRe             (100 intervals)
c --- ipalet =12      --  NCL's ReOrYeGrBlViWh             (100 intervals)
c --- ipalet =13      --  NCL's +WhViBlGrYeOrRe            (100 intervals)
c --- ipalet =14      --  NCL's ReOrYeGrBlViWh+            (100 intervals)
c --- ipalet =15      --  MATLAB's HOT                     ( 20 intervals)
c --- ipalet =16      --  MATLAB's HOT, inverted           ( 20 intervals)
c --- ipalet =17      --  NCL's BlAqGrYeOrRe               (100 intervals)
c --- ipalet =18      --  NCL's ReOrYeGrAqBl               (100 intervals)
c --- ipalet =19      --  NRL's Bl/lt-Bl/Ye/Re             ( 20 intervals)
c
      common /colopt/ ipalet,nbase,ibase(2,99)
c
c --- number of contour intervals for each palette
      integer    maxpal
      real cntrs(-2:99)
c
      call xcspmd
      allocate( work(idm,jdm) )
c
      call zaiost
      lp=6
      film=onemm
c
      call colors_no(cntrs,maxpal)
c
c --- Use environment variable PLOT_MASKED to control data void plotting
      flnm2 = ' '
      call getenv('PLOT_MASKED',flnm2)
*     write (lp,'(2a)') 'PLOT_MASKED  : ',trim(flnm2)
      lmskplt = trim(flnm2).eq.'yes' .or. trim(flnm2).eq.'YES'
      if     (lmskplt) then
        write (lp,'(a)') 'plot masked sea regions in gray'
      endif
      call flush(lp)
c
c --- Use environment variable OVERLAY to control overlay
      flnm2 = ' '
      call getenv('OVERLAY',flnm2)
*     write (lp,'(2a)') 'OVERLAY      : ',trim(flnm2)
      xyward = .true.
      if     (flnm2(1:5).eq.'ENVEC') then
        xyward = .false.
        flnm2 = flnm2(3:)
      elseif (flnm2(1:5).eq.'XYVEC') then
        flnm2 = flnm2(3:)
      endif
      if     (trim(flnm2).eq.'VECTOR') then
        kover = 2
      elseif (trim(flnm2).eq.'VECBATH') then
        kover  = 3
        lpalet = 0  !label bathy contours
      elseif (trim(flnm2).eq.'VECCONT') then
        kover  = 4
        lpalet = 0  !label line contours
      elseif (trim(flnm2).eq.'CONTOUR') then
        kover  = 1
        lpalet = 0  !label line contours
      elseif (trim(flnm2).eq.'VECBATH_NL') then
        kover  =  3
        lpalet = -9  !don't label bathy contours
      elseif (trim(flnm2).eq.'VECCONT_NL') then
        kover  =  4
        lpalet = -9  !don't label line contours
      elseif (trim(flnm2).eq.'CONTOUR_NL') then
        kover  =  1
        lpalet = -9  !don't label line contours
      else
        flnm2 = 'NONE'
        kover = 0
      endif
      write (lp,'(2a)') 'overlay  type: ',trim(flnm2)
      if     (kover.ge.2) then  !vector-overlay
        if     (xyward) then
          write (lp,'(a)')  'input vectors: xward,yward'
        else
          write (lp,'(a)')  'input vectors: eward,nward'
        endif
      endif
      call flush(lp)
c
      if     (kover.ne.2) then
        line_new = ' '
        call getenv('CONTOUR_PLTHICK',line_new)
        if     (line_new.ne.' ') then
          read(line_new,*) plthickc
        else
          plthickc = 1.0
        endif
        line_new = ' '
        call getenv('CONTOUR_PLCOLOR',line_new)
        if     (line_new.ne.' ') then
          read(line_new,*) plindexc
        else
          plindexc = 1
        endif
      endif !.not.VECTOR
c
c --- read field data
c
        if     (kover.eq.0) then  !no overlay
c ---     'flnm  ' = name of file containing the actual data
          read (*,'(a)') flnm
          write (lp,'(2a)') 'input    file: ',trim(flnm)
          call flush(lp)
        elseif (kover.eq.1) then  !field-overlay
c ---     'flnm  ' = name of file containing the actual data
c ---     'flnm2 ' = name of file containing the actual data for overlay
          read (*,'(a)') flnm
          write (lp,'(2a)') 'input    file: ',trim(flnm)
          call flush(lp)
          read (*,'(a)') flnm2
          write (lp,'(2a)') 'overlay  file: ',trim(flnm2)
          call flush(lp)
          if     (flnm.eq.flnm2) then
            write(lp,'(/a/)') 'error - flnm == flnm2 not allowed'
            call flush(lp)
            stop
          endif
        elseif (kover.eq.2) then  !vector-overlay
c ---     'flnm  ' = name of file containing the actual data
c ---     'flnmu ' = name of file containing the actual data for u-vector
c ---     'flnmv ' = name of file containing the actual data for v-vector
          read (*,'(a)') flnm
          write (lp,'(2a)') 'input    file: ',trim(flnm)
          call flush(lp)
          read (*,'(a)') flnmu
          write (lp,'(2a)') 'u-vector file: ',trim(flnmu)
          call flush(lp)
          if     (flnm.eq.flnmu) then
            write(lp,'(/a/)') 'error - flnm == flnmu not allowed'
            call flush(lp)
            stop
          endif
          read (*,'(a)') flnmv
          if     (flnmv.ne.flnmu) then
            write (lp,'(2a)') 'v-vector file: ',trim(flnmv)
            call flush(lp)
          else
            write (lp,'(2a)') 'v-vector file: ','same as u-vector file'
            call flush(lp)
          endif
        elseif (kover.eq.4) then  !contour and vector overlay
c ---     'flnm  ' = name of file containing the actual data
c ---     'flnm2 ' = name of file containing the actual data for overlay
c ---     'flnmu ' = name of file containing the actual data for u-vector
c ---     'flnmv ' = name of file containing the actual data for v-vector
          read (*,'(a)') flnm
          write (lp,'(2a)') 'input    file: ',trim(flnm)
          call flush(lp)
          read (*,'(a)') flnm2
          write (lp,'(2a)') 'overlay  file: ',trim(flnm2)
          call flush(lp)
          if     (flnm.eq.flnm2) then
            write(lp,'(/a/)') 'error - flnm == flnm2 not allowed'
            call flush(lp)
            stop
          endif
          read (*,'(a)') flnmu
          write (lp,'(2a)') 'u-vector file: ',trim(flnmu)
          call flush(lp)
          if     (flnm.eq.flnmu) then
            write(lp,'(/a/)') 'error - flnm == flnmu not allowed'
            call flush(lp)
            stop
          endif
          if     (flnm2.eq.flnmu) then
            write(lp,'(/a/)') 'error - flnm2 == flnmu not allowed'
            call flush(lp)
            stop
          endif
          read (*,'(a)') flnmv
          if     (flnmv.ne.flnmu) then
            write (lp,'(2a)') 'v-vector file: ',trim(flnmv)
            call flush(lp)
          else
            write (lp,'(2a)') 'v-vector file: ','same as u-vector file'
            call flush(lp)
          endif
        elseif (kover.eq.3) then  !vector-overlay and bathymetry
c ---     'flnm  ' = name of file containing the actual data
c ---     'flnmu ' = name of file containing the actual data for u-vector
c ---     'flnmv ' = name of file containing the actual data for v-vector
c ---     'qqbath' = bathymetry contour interval (<0 no plot; 0 from field)
c ---       or
c ---     'qqbth1' = 1st bathymetry contour interval (<=0 no plot)
c ---     'qqbthm' = maximum depth for 1st bathymetry contours
c ---     'qqbth2' = 2nd bathymetry contour interval (<=0 no plot)
          read (*,'(a)') flnm
          write (lp,'(2a)') 'input    file: ',trim(flnm)
          call flush(lp)
          read (*,'(a)') flnmu
          write (lp,'(2a)') 'u-vector file: ',trim(flnmu)
          call flush(lp)
          if     (flnm.eq.flnmu) then
            write(lp,'(/a/)') 'error - flnm == flnmu not allowed'
            call flush(lp)
            stop
          endif
          read (*,'(a)') flnmv
          if     (flnmv.ne.flnmu) then
            write (lp,'(2a)') 'v-vector file: ',trim(flnmv)
            call flush(lp)
          else
            write (lp,'(2a)') 'v-vector file: ','same as u-vector file'
            call flush(lp)
          endif
          call blkinr2(qqin,i,
     &                 'qqbath','("blkinr: ",a6," =",1pe12.3," m")',
     &                 'qqbth1','("blkinr: ",a6," =",1pe12.3," m")')
          if (i.eq.1) then !'qqbath'
            qqbath = qqin
            qqbth1 = -1.0 !no plot of this kind
            qqbthm =  0.0
            qqbth2 = -1.0
          else
            qqbath = -1.0 !no plot of this kind
            qqbth1 = qqin
            call blkinr(qqbthm,
     &                 'qqbthm','("blkinr: ",a6," =",1pe12.3," m")')
            call blkinr(qqbth2,
     &                 'qqbth2','("blkinr: ",a6," =",1pe12.3," m")')
          endif
        endif !kover
c
c ---   Use environment variable TRACKS or TRACKS_XY for markers and tracks
        flnmtr = ' '
        call getenv('TRACKS',flnmtr)
        ltrack = flnmtr.ne.' '
        if     (ltrack) then
          write (lp,'(2a)') 'tracks   file: ',trim(flnmtr)
          ltrack_xy = .false.
        else
          flnmtr = ' '
          call getenv('TRACKS_XY',flnmtr)
          ltrack    = flnmtr.ne.' '
          ltrack_xy = ltrack
          if     (ltrack) then
            write (lp,'(2a)') 'tracksxy file: ',trim(flnmtr)
          endif
        endif
        call flush(lp)
c
c ---   'region' = name of model region (e.g. ATLa2.00)
        read (*,'(a)') region
        write (lp,'(2a)') '       region: ',trim(region)
        call flush(lp)
c
c ---   'idm   ' = longitudinal array size
c ---   'jdm   ' = latitudinal  array size
        call blkini(ii,    'idm   ')
        call blkini(jj,    'jdm   ')
        if     (ii.ne.idm .or. jj.ne.jdm) then
          write(lp,*)
          write(lp,*) 'error - wrong idm or jdm (should be:',
     .                                           idm,jdm,')'
          write(lp,*)
          call flush(lp)
          stop
        endif
c
c ---   'nperfr' = number of horizontal plots per frame
c ---   'lalolb' = spacing of latitude/longitude labels
c ---   'lalogr' = spacing of latitude/longitude grid over land (<0 land+sea)
c ---      (abs(lalogr)>1000: spacing is (abs(lalogr)-1000)/100.0)
c ---   'loclab' = flag indicating the location of the contour lablel
c ---      (0=input,1=upper-right,2=lower-right,3=lower-left,4=upper-left)
c ---   'ilabel' = i-index for contour lablel (loclab=0 only)
c ---   'jlabel' = j-index for contour lablel (loclab=0 only)
c ---   'locbar' = flag indicating the location of the color bar
c ---      (vertical:   10=right, 11=ur,12=lr,13=ll,14=ul,15=cr,16=cl)
c ---      (horizontal: 20=bottom,21=ur,22=lr,23=ll,24=ul,25=ct,26=cb)
c ---   'gray  ' = no color (0=color,1=neg.gray,2=pos.gray), OPTIONAL default 0
c ---   'kpalet' = palete (0=none,1=pastel/gray,>1 color)
c ---              paletes >1 require input of the central contour
c ---              -9 adds near-center line contours to palete 9
c ---              <-2 use -kpalet and line contour the center value
        call blkini(nperfr,'nperfr')
        call blkini(lalolb,'lalolb')
        call blkini(lalogr,'lalogr')
        call blkini(loclab,'loclab')
        if     (loclab.eq.0) then
          call blkini(ilabel,'ilabel')
          call blkini(jlabel,'jlabel')
        endif
        call blkini(locbar,'locbar')
        call blkini2(i,j,  'gray  ','kpalet')  !read gray or kpalet
        if (j.eq.1) then
          gray   = i
          call blkini(kpalet,'kpalet')
          if     (gray.ne.0 .and. kpalet.gt.1) then
            write(lp,*)
            write(lp,*) 'error - illegal kpalet for gray case'
            write(lp,*)
            stop
          endif
        else
          gray   = 0  !color allowed
          kpalet = i
        endif
c
        kpalet_neg = kpalet.eq.-9
        if     (kpalet_neg) then
          kpalet = 9
        endif
        kpalet_cen = kpalet.lt.-2
        if     (kpalet_cen) then
          kpalet = -kpalet
        endif
c
        if     (kpalet.lt.0 .or. kpalet.gt.maxpal) then
          write(lp,*)
          write(lp,*) 'error - illegal kpalet'
          write(lp,*)
          stop
        endif
c
        if     (kover.ge.2) then  !vector-overlay
c ---   'i_th  ' = draw a vector in only every i_th column
c ---   'j_th  ' = draw a vector in only every j_th row
        call blkini(i_th,  'i_th  ')
        call blkini(j_th,  'j_th  ')
        endif !vector-overlay
c
c ---   'iorign' = i-origin of plotted subregion
c ---   'jorign' = j-origin of plotted subregion
c ---   'idmp  ' = i-extent of plotted subregion (<=idm; 0 implies idm)
c ---   'jdmp  ' = j-extent of plotted subregion (<=jdm; 0 implies jdm)
        call blkini(iorign,'iorign')
        call blkini(jorign,'jorign')
        call blkini(ii,    'idmp  ')
        call blkini(jj,    'jdmp  ')
        if     (ii.eq.0) then
          ii=idm
        endif
        if     (jj.eq.0) then
          jj=jdm
        endif
c ---   'iorign,jorign' denote the origin of the subgrid to be extracted
c ---   from the full history grid (dimensioned idm x jdm).
c ---   The size of the subgrid is determined by ii,jj.
        write (lp,'(2(a,i5),9x,2(a,i5))') 'extracting i =',iorign,
     .    ' ...',iorign+ii-1,'j =',jorign,' ...',jorign+jj-1
c
        if     (iorign.lt.1 .or. jorign.lt.1) then
          write(lp,*)
          write(lp,*) 'error - [ij]orign must be positive'
          write(lp,*)
          stop
        endif
c
c --- array allocation
c
      call plot_alloc_field
c
      if     (nperfr.eq.1 .or. nquad.lt.0) then
        siz=.46
        csn=-0.9
        csb=-1.2
      elseif (nperfr.eq.2) then
        siz=.43
        csn=-0.9
        csb=-1.2
      elseif (nperfr.eq.4) then
        siz=.35
        csn=-0.9*0.7
        csb=-1.2*0.7
      else
        siz=.25
        csn=-0.9*0.4
        csb=-1.2*0.4
      endif
      chrsiz=.009*float(ii-1)/
     .       (2.*siz*min(1.,float(ii-1)/float(jj-1)))
      write(lp,*) 'chrsiz = ',chrsiz,ii/chrsiz,jj/chrsiz
      if     (loclab.eq.0) then
c ---   contour stats w.r.t. ilabel,jlabel (center of region text)
        xlab0 = ilabel
        xlab1 = ilabel
        xlab2 = ilabel
        xlabv = ilabel
        ylab0 = jlabel
        ylab1 = jlabel - 3.0*chrsiz
        ylab2 = jlabel - 6.0*chrsiz
        ylabv = jlabel - 7.0*chrsiz
      elseif (loclab.eq.1) then
c ---   contour stats in upper right of horizontal plot
        xlab0 = ii-1-10.0*chrsiz
        xlab1 = ii-1-10.0*chrsiz
        xlab2 = ii-1-10.0*chrsiz
        xlabv = ii-1-10.0*chrsiz
        ylab0 = jj-1- 3.0*chrsiz
        ylab1 = jj-1- 6.0*chrsiz
        ylab2 = jj-1- 9.0*chrsiz
        ylabv = jj-1-10.0*chrsiz
      elseif (loclab.eq.2) then
c ---   contour stats in lower right of horizontal plot
        xlab0 = ii-1-10.0*chrsiz
        xlab1 = ii-1-10.0*chrsiz
        xlab2 = ii-1-10.0*chrsiz
        xlabv = ii-1-10.0*chrsiz
        ylab0 =    1 + 9.0*chrsiz
        ylab1 =    1 + 5.0*chrsiz
        ylab2 =    1 + 3.0*chrsiz
        ylabv =    1 +10.0*chrsiz
      elseif (loclab.eq.3) then
c ---   contour stats in lower left  of horizontal plot
        xlab0 =    1 +10.0*chrsiz
        xlab1 =    1 +10.0*chrsiz
        xlab2 =    1 +10.0*chrsiz
        xlabv =    1 +10.0*chrsiz
        ylab0 =    1 + 9.0*chrsiz
        ylab1 =    1 + 5.0*chrsiz
        ylab2 =    1 + 3.0*chrsiz
        ylabv =    1 +10.0*chrsiz
      elseif (loclab.eq.4) then
c ---   contour stats in upper left  of horizontal plot
        xlab0 =    1 +10.0*chrsiz
        xlab1 =    1 +10.0*chrsiz
        xlab2 =    1 +10.0*chrsiz
        xlabv =    1 +10.0*chrsiz
        ylab0 = jj-1- 3.0*chrsiz
        ylab1 = jj-1- 6.0*chrsiz
        ylab2 = jj-1- 9.0*chrsiz
        ylabv = jj-1-10.0*chrsiz
      else
        write(lp,*)
        write(lp,*) 'error - unknown loclab = ',loclab
        write(lp,*)
        call flush(lp)
        stop
      endif
      write (lp,'(a,i3,a)') '... plotting',nperfr,' maps per frame'
      call flush(lp)
c
c --- read the basin depth file, form the land/sea masks.
c
      if     (kover.ge.2) then  !vector-overlay
        allocate( scpx(ii,jj), scpy(ii,jj) )
        if     (.not.xyward) then
          allocate( pang(ii,jj) )
        endif
      endif
      dpthfil = 'regional.depth'
      call getdepth(work)
      do j= 1,jj
        do i= 1,ii
          if     (depths(i,j).gt.0.0) then
            ip(i,j) = 1
          else
            ip(i,j) = 0
          endif
        enddo
      enddo
c
c --- initialize for plotting.
c
      call opngks
c
      ipalet=kpalet
      nbase =0
      ibase =0
      call colors(gray)  !define color table
c
      call gsclip(0)
c
c --- ---------------------------
c --- loop through selected plots
c --- ---------------------------
c
      call zaiopf(flnm, 'old', 14)
      if     (kover.eq.1 .or. kover.eq.4) then
        call zaiopf(flnm2,'old', 15)
      endif
      if     (kover.ge.2) then
        call zaiopf(flnmu,'old', 17)
        if     (flnmu.ne.flnmv) then
          call zaiopf(flnmv,'old', 16)
        endif !separate u&v files
        allocate( ufield(ii,jj), vfield(ii,jj) )
      endif
      if     (lmskplt) then
        allocate( fieldm(ii,jj) )
      else
        allocate( fieldm(1,1) )
      endif
c
      nold  = 0
      nold2 = 0
      noldv = 0
      do
c ---   'nrec  ' = next record to plot    (arbitrary order, <0 to end)
        call blkini(nrec,   'nrec  ')
        if     (nrec.lt.0) then
          exit  ! end of plots
        endif
        if     (kover.ne.0) then  !field-overlay or vector-overlay
c ---   'nrec2 ' = next record to overlay (arbitrary order)
        call blkini(nrec2,  'nrec2 ')
        endif !field-overlay or vector-overlay
c
        if     (nrec.le.nold) then  !reset to start of file
          call zaiorw(14)
          nold = 0
        endif
        do nr= nold+1,nrec-1
          call zaiosk(14)
        enddo
        call zaiord(  work,ip,.false., amn,amx, 14)
        call extrct_p(work,idm,jdm,iorign,jorign,
     &                field,ii,jj)
        nold = nrec
c
c ---   'plabel' = plot label
c ---   'qscale' = scale factor for plot
c ---   'qq    ' = contour interval (<0 no plot; 0 from field)
        read (*,'(a)') plabel
        call blkinr(qscale,'qscale','("blkinr: ",a6," =",1pe12.3)')
        call blkinr(qqin,  'qq    ','("blkinr: ",a6," =",1pe12.3)')
        if (qqin.ge.0.0) then
          if     (lmskplt) then
            do j= 1,jj
              do i= 1,ii
                if     (ip(i,j).eq.1) then
                  if     (field(i,j).lt.0.5*spval) then
                    fieldm(i,j) = 1.0  !ignored
                  else
                    fieldm(i,j) = 0.0  !gray
                  endif
                else
                  fieldm(i,j) = flag
                endif
              enddo
            enddo
          endif !lmskplt
c
c ---     check that bathymetry is consistent with this field.
c
          ibadl = 0
          ibads = 0
          do j= 1,jj
            do i= 1,ii
              if     (ip(i,j).eq.1) then
                if     (field(i,j).lt.0.5*spval) then
                  field(i,j) = qscale*field(i,j)
                else
                  field(i,j) = flag
                  ibads = ibads + 1   ! topo sea, field land (data void)
*                 if     (mod(ibads,100).eq.1) then
*                   write(lp,*) 'topo sea, field land at i,j = ',i,j
*                 endif
                endif
              else
                field(i,j) = flag
                if     (field(i,j).lt.0.5*spval) then
                  ibadl = ibadl + 1   ! topo land, field sea
*                 if     (mod(ibadl,100).eq.1) then
*                   write(lp,*) 'topo land, field sea at i,j = ',i,j
*    &                          ,field(i,j)
*                 endif
                endif
              endif
            enddo
          enddo
          if     (ibads.ne.0 .and. .not.lmskplt) then
            write(lp,*)
            write(lp,*) 'warning - wrong bathymetry for this field'
            write(lp,*) 'number of topo sea  mismatches = ',ibads
            write(lp,*) 'number of topo land mismatches = ',ibadl
            write(lp,*)
            call flush(lp)
          endif
          if (kpalet.ge.2 .and. qqin.eq.0.0) then
            qq=contur_colors(field,ii,ii1,jj1,nint(cntrs(kpalet)))
          else
            qq=contur(field,ii,ii1,jj1)
          endif
          if (qqin.ne.0.0) qq=qqin
          write(6,*) 'field = ',amn,amx,qq
          ipalet=kpalet
          if (kpalet.ge.2) then
            if (qqin.gt.0.0) then
c ---         'center' = central contoured value
              call blkinr(qqc,'center','("blkinr: ",a6," =",1pe12.3)')
            else
              qqc = qq*nint(0.5*(amn+amx)/qq)
            endif
            qqmn = qqc-0.5*qq*cntrs(kpalet)
            qqmx = qqc+0.5*qq*cntrs(kpalet)
          else
            qqmn = 0.0
            qqmx = 0.0
          endif
          nquad2=nquad
          call horplt_mask(
     .                field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                0,plabel(1:len_trim(plabel)),
     .                0.0,nquad,.true.,lalolb,lalogr,
     .                fieldm,lmskplt)
          if     (kpalet_neg) then  !line contours near center.
            ipalet=-9  !lines without labels
            qqmn = qqc-qq
            qqmx = qqc
            ldash = 1+0*2+1*4+0*8+1*16+0*32+1*64+0*128+1*256+0*512
            call horplt(field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                  ldash,plabel(1:len_trim(plabel)),  !dashed center
     .                  0.0,nquad2,.false.,lalolb,lalogr)
            qqmn = qqc-qq
            qqmx = qqc+qq
            qq   = 2.0*qq
            call horplt(field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                  0,plabel(1:len_trim(plabel)),      !solid both sides
     .                  0.0,nquad2,.false.,lalolb,lalogr)
          endif !kpalet_neg
          if     (kpalet_cen) then  !line contour the center value.
            ipalet=-9  !lines without labels
            qqmn = qqc
            qqmx = qqc+0.5*qq
            call horplt(field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                  0,plabel(1:len_trim(plabel)),      !solid contour
     .                  0.0,nquad2,.false.,lalolb,lalogr)
          endif !kpalet_cen
          write (lp,'(a,a)')
     .      ' now plotting: ',plabel(1:len_trim(plabel))
          call flush(lp)
          call pcloqu(xlab0,ylab0,trim(region),csb,0.,0)
          if     (qq.lt.0.005) then
            write (text1,'(f10.4)') qq
            write (text2,'(f10.3)') amn
            write (text3,'(f10.3)') amx
          elseif (qq.lt.0.05) then
            write (text1,'(f10.3)') qq
            write (text2,'(f10.2)') amn
            write (text3,'(f10.2)') amx
          elseif  (qq.lt.0.5) then
            write (text1,'(f10.2)') qq
            write (text2,'(f10.1)') amn
            write (text3,'(f10.1)') amx
          else
            write (text1,'(f10.1)') qq
            write (text2,'(f10.0)') amn
            write (text3,'(f10.0)') amx
          endif
          if     (text2( 7:10).eq.'.000') then
             text2( 7:10) = ' '
          elseif (text2( 8:10).eq. '.00' .or.
     &            text2( 8:10).eq. '000'     ) then
             text2( 8:10) = ' '
          elseif (text2( 9:10).eq.  '.0' .or.
     &            text2( 9:10).eq.  '00'     ) then
             text2( 9:10) = ' '
          elseif (text2(10:10).eq.   '.' .or.
     &            text2(10:10).eq.   '0'     ) then
             text2(10:10) = ' '
          endif
          if     (text3( 7:10).eq.'.000') then
             text3( 7:10) = ' '
          elseif (text3( 8:10).eq. '.00' .or.
     &            text3( 8:10).eq. '000'     ) then
             text3( 8:10) = ' '
          elseif (text3( 9:10).eq.  '.0' .or.
     &            text3( 9:10).eq.  '00'     ) then
             text3( 9:10) = ' '
          elseif (text3(10:10).eq.   '.' .or.
     &            text3(10:10).eq.   '0'     ) then
             text3(10:10) = ' '
          endif
          if     (kover.lt.2) then  !no-overlay or field-overlay
            text = 'ci ' // adjustl(text1)
            call pcloqu(xlab1,ylab1,trim(text),csn,0.,0)
            text = trim(adjustl(text2)) // ' to ' // adjustl(text3)
            call pcloqu(xlab2,ylab2,trim(text),csn,0.,0)
          endif !no-overlay or field-overlay
c
          if     (kover.eq.1 .or. kover.eq.4) then  !field-overlay
          if     (nrec2.le.nold2) then  !reset to start of file
            call zaiorw(15)
            nold2 = 0
          endif
          do nr= nold2+1,nrec2-1
            call zaiosk(15)
          enddo
          call zaiord(  work,ip,.false., amn,amx, 15)
          call extrct_p(work,idm,jdm,iorign,jorign,
     &                  field,ii,jj)
          nold2 = nrec2
c
c ---     'qq2   ' = contour interval (<0 no plot; 0 from field)
          call blkinr(qqin,  'qq2   ','("blkinr: ",a6," =",1pe12.3)')
c
c ---     check that bathymetry is consistent with this field.
c
          ibadl = 0
          ibads = 0
          do j= 1,jj
            do i= 1,ii
              if     (ip(i,j).eq.1) then
                if     (field(i,j).gt.0.5*spval) then
                  field(i,j) = flag
                  ibads = ibads + 1   ! topo sea, field land
*                 if     (mod(ibads,100).eq.1) then
*                   write(lp,*) 'topo sea, field land at i,j = ',i,j
*                 endif
                endif
              else
                field(i,j) = flag
                if     (field(i,j).lt.0.5*spval) then
                  ibadl = ibadl + 1   ! topo land, field sea
*                 if     (mod(ibadl,100).eq.1) then
*                   write(lp,*) 'topo land, field sea at i,j = ',i,j
*    &                          ,field(i,j)
*                 endif
                endif
              endif
            enddo
          enddo
          if     (ibads.ne.0) then
            write(lp,*)
            write(lp,*) 'warning - wrong bathymetry for this field'
            write(lp,*) 'number of topo sea  mismatches = ',ibads
            write(lp,*) 'number of topo land mismatches = ',ibadl
            write(lp,*)
            call flush(lp)
          endif
          qq=contur(field,ii,ii1,jj1)
          if (qqin.ne.0.0) qq=qqin
          write(6,*) 'overlay = ',amn,amx,qq
          ipalet=lpalet !0 or -9
          qqmn = 0.0
          qqmx = 0.0
          call plotif(0.0,0.0,2)
          call gslwsc(plthickc)
          call gsplci(plindexc)
          call gstxci(plindexc)
          call gsln(1)
          call plotif(0.0,0.0,2)
          call horplt(field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                0,plabel(1:len_trim(plabel)),
     .                0.0,nquad2,.false.,lalolb,lalogr)
          call plotif(0.0,0.0,2)
          call gslwsc(1.0)
          call gsplci(1)
          call gstxci(1)
          call gsln(1)
          call plotif(0.0,0.0,2)
          if     (kover.eq.4) then  !field and vector overlay
c ---     'nrec2 ' = next vector record to overlay (arbitrary order)
          call blkini(nrec2,  'nrec2 ')
          endif !field and vector overlay
          endif !field-overlay
c
          if     (kover.eq.3) then  !bathymetry overlay
          do j= 1,jj
            do i= 1,ii
              if     (ip(i,j).eq.1) then
                field(i,j) = depths(i,j)
              else
                field(i,j) = flag
              endif
            enddo
          enddo
          qq=contur(field,ii,ii1,jj1)
          if     (qqbath.ge.0.0) then
            if (qqbath.ne.0.0) qq=qqbath
            write(6,*) 'bathy   = ',amn,amx,qq
            ipalet=lpalet !0 or -9
            qqmn = 0.0
            qqmx = 0.0
            call plotif(0.0,0.0,2)
            call gslwsc(plthickc)
            call gsplci(plindexc)
            call gstxci(plindexc)
            call gsln(1)
            call plotif(0.0,0.0,2)
            call horplt(field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                  0,plabel(1:len_trim(plabel)),
     .                  0.0,nquad2,.false.,lalolb,lalogr)
            call plotif(0.0,0.0,2)
            call gslwsc(1.0)
            call gsplci(1)
            call gstxci(1)
            call gsln(1)
            call plotif(0.0,0.0,2)
          elseif (qqbth1.gt.0.0) then
            ipalet=lpalet !0 or -9
            call plotif(0.0,0.0,2)
            call gslwsc(plthickc)
            call gsplci(plindexc)
            call gstxci(plindexc)
            call gsln(1)
            call plotif(0.0,0.0,2)
            qq   = qqbth1
            qqmn = qqbth1
            qqmx = qqbthm
            write(6,*) 'bathy1  = ',qqmn,qqmx,qq
            call horplt(field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                  0,plabel(1:len_trim(plabel)),
     .                  0.0,nquad2,.false.,lalolb,lalogr)
            call plotif(0.0,0.0,2)
            if     (qqbth2.gt.0.0) then
              qq   = qqbth2
              qqmn = qqbthm
              qqmx = amx
              write(6,*) 'bathy2  = ',qqmn,qqmx,qq
              call horplt(field,plon,plat,ii,jj,ii1,jj1,qqmn,qqmx,qq,
     .                    0,plabel(1:len_trim(plabel)),
     .                    0.0,nquad2,.false.,lalolb,lalogr)
              call plotif(0.0,0.0,2)
            endif !qqbth2
            call gslwsc(1.0)
            call gsplci(1)
            call gstxci(1)
            call gsln(1)
            call plotif(0.0,0.0,2)
          endif !qqbath:qqbth1
          endif !bathy-overlay
c
          if     (kover.ge.2) then  !vector-overlay
          if     (nrec2.le.noldv) then  !reset to start of file
            call zaiorw(17)
            if     (flnmu.ne.flnmv) then
              call zaiorw(16)
            endif !separate u&v files
            noldv = 0
          endif
          do nr= noldv+1,nrec2-1
            call zaiosk(17)
            if     (flnmu.ne.flnmv) then
              call zaiosk(16)
            endif !separate u&v files
          enddo
          call zaiord(   work,ip,.false., amn,amx, 17)
          call extrct_pv(work,idm,jdm,iorign,jorign,
     &                   ufield,ii,jj)
          if     (flnmu.ne.flnmv) then !separate u&v files
            call zaiord(  work,ip,.false., amn,amx, 16)
            noldv = nrec2
          else !single u&v file
            call zaiord(  work,ip,.false., amn,amx, 17)
            noldv = nrec2+1
          endif
          call extrct_pv(work,idm,jdm,iorign,jorign,
     &                   vfield,ii,jj)
c
c ---     'vscale' = scale factor for vector (convert to cm/s)
          call blkinr(qscale,'vscale','("blkinr: ",a6," =",1pe12.3)')
          call blkinr2(qqin,i,
     &                 'vthrsh','("blkinr: ",a6," =",1pe12.3," cm/s")',
     &                 'vrefmx','("blkinr: ",a6," =",1pe12.3," cm/s")')
          if (i.eq.1) then !'vthrsh'
c
c ---       'vthrsh' = velocity plot threshold (standard vectors)
            thresh=qqin
            do j= 1,jj-1,j_th
              do i= 1,ii-1,i_th
                if     (ip(i,j).eq.1 .and.
     &                  max(ufield(i,j),vfield(i,j)).lt.0.5*spval) then
                  if     (.not.xyward) then
                    qx=cos(-pang(i,j))*ufield(i,j) +
     &                 sin( pang(i,j))*vfield(i,j)
                    qy=cos(-pang(i,j))*vfield(i,j) -
     &                 sin( pang(i,j))*ufield(i,j)
                    qu=qscale*qx*float(i_th+j_th)/(4.*thresh)
                    qv=qscale*qy*float(i_th+j_th)/(4.*thresh)
                  else
                    qu=qscale*ufield(i,j)*float(i_th+j_th)/(4.*thresh)
                    qv=qscale*vfield(i,j)*float(i_th+j_th)/(4.*thresh)
                  endif
                  call arrow1(float(i)-qu,float(j)-qv
     &                       ,float(i)+qu,float(j)+qv,
     &                        0.5*float(i_th+j_th))
                endif !sea
              enddo !i
            enddo !j
            call legend1(xlabv,ylabv,thresh,0.5*float(i_th+j_th))
          else !'vrefmx'
c
c ---       'vrefmx' = velocity plot maximum (streamline vectors)
c ---       'vrefpl' = velocity plot maximum plot length (NDC: 0. to 1.)
            vrefmx = qqin
            call blkinr(vrefpl,'vrefpl','("blkinr: ",a6," =",1pe12.3)')
            do j= 1,jj
              do i= 1,ii
                if     (ip(i,j).eq.1 .and.
     &                  max(ufield(i,j),vfield(i,j)).lt.0.5*spval) then
                  if     (.not.xyward) then
                    qx=cos(-pang(i,j))*ufield(i,j) +
     &                 sin( pang(i,j))*vfield(i,j)
                    qy=cos(-pang(i,j))*vfield(i,j) -
     &                 sin( pang(i,j))*ufield(i,j)
                  else
                    qx=ufield(i,j)
                    qy=vfield(i,j)
                  endif
                  ufield(i,j) = qscale*qx
                  vfield(i,j) = qscale*qy
                else !land
                  ufield(i,j) = 0.0
                  vfield(i,j) = 0.0
                endif
              enddo !i
            enddo !j
            line_new = ' '
            call getenv('ARROW_UNITS',line_new)
            if     (line_new.ne.' ') then
              cunits = line_new
            else
              cunits = "cm/s"
            endif
            line_new = ' '
            call getenv('ARROW_XEDGE',line_new)
            if     (line_new.ne.' ') then
              read(line_new,*) xedge
            else
              xedge = 1.0
            endif
            line_new = ' '
            call getenv('ARROW_YEDGE',line_new)
            if     (line_new.ne.' ') then
              read(line_new,*) yedge
            else
              yedge = 1.0
            endif
            line_new = ' '
            call getenv('ARROW_PLTHICK',line_new)
            if     (line_new.ne.' ') then
              read(line_new,*) plthickv
            else
              plthickv = 1.0
            endif
            line_new = ' '
            call getenv('ARROW_PLCOLOR',line_new)
            if     (line_new.ne.' ') then
              read(line_new,*) plindexv
            else
              plindexv = 1
            endif
            call plotif(0.0,0.0,2)
            call gslwsc(plthickv)
            call gsplci(plindexv)
            call gsln(1)
            call plotif(0.0,0.0,2)
            call carrow(ufield,vfield,scpx,scpy,ii,ii,jj,
     &                  i_th,j_th,xedge,yedge,vrefmx,vrefpl)
            text = trim(adjustl(text2)) // ' to ' // adjustl(text3)
            call pcloqu(xlab1,ylab1,trim(text),csn,0.,0)
            ylabc=0.5*(ylab1+ylab2)
            if     (vrefpl.le.0.11) then
              call clegend(xlab1,ylabc,ylab2,vrefmx,
     &                                       vrefpl,
     &                                       cunits)
            elseif (vrefpl.le.0.21) then
              call clegend(xlab1,ylabc,ylab2,vrefmx/2.0,
     &                                       vrefpl/2.0,
     &                                       cunits)
            elseif (vrefpl.le.0.41) then
              call clegend(xlab1,ylabc,ylab2,vrefmx/4.0,
     &                                       vrefpl/4.0,
     &                                       cunits)
            else
              call clegend(xlab1,ylabc,ylab2,vrefmx/8.0,
     &                                       vrefpl/8.0,
     &                                       cunits)
            endif
            call plotif(0.0,0.0,2)
            call gslwsc(1.0)
            call gsplci(1)
            call gsln(1)
            call plotif(0.0,0.0,2)
          endif !'vthrsh';'vrefmx'
          if (kpalet.gt.1) then
            ipalet=kpalet
            call colbar_redraw
          endif !kpalet
          endif !vector-overlay
c
c ---     tracks
c
          if     (ltrack) then
            call tracks(plon,plat,ii,jj, ltrack_xy, flnmtr)
          endif
c
          if (nquad.eq.0) call fram(ncount)
        endif
      enddo
      call clsgks
      stop '(normal)'
      end


      SUBROUTINE ATTUDE(TSTOP,TIME,FREQ,DELTAT,JPLUSE,LSAVE,JUMP)
C
C        'ATTUDE' DETERMINES THE START AND STOP TIME OF THRUSTING FOR
C        THE ATTITUDE CONTROL SYSTEM. IT ALSO SETS THE INTEGRATION TIME
C        STEP DURING THE THRUSTING OPERATION
C
        IMPLICIT REAL*8 (A-H,O-Z)
      INTEGER*4 ACNTRL
C
      COMMON/CONSTS/ PI,TWOPI,RADIAN
C
      COMMON/MOMENT/ ACNTRL,IVISCS,IATTDE,IMGMTS,IWHEEL,NPULSE
C
      COMMON/OUTONE/ OMEGL,VSUBL,ASUBM(3),CMX1,SIMPX,SB(3)
C
      COMMON/RATTDE/ DTMXA,PXI,PXO,EIT,REFTIM,TMX1,TMX2,CMX,ISW
C
C
      DATA N /0/
C
      IF(JUMP.EQ.1) GO TO 10
      IF(TIME.LT.TMX1) RETURN
   10 GO TO (20,30,40),JUMP
   20 N=N+1
      JUMP=2
      TSAVE=TSTOP
      FSAVE=FREQ
      DSAVE=DELTAT
      TSTOP=TMX1
      FREQ=TMX1 - REFTIM
      FREQ=DMIN1(FREQ,FSAVE)
      DELTAT=DMIN1(FREQ/4.D0,DSAVE)
      REFTIM=0.D0
      TS=DMOD(TSTOP,8.64D4)
      TS=HMSOUT(TS)
      WRITE(6,10000) N,TS
      WRITE(6,10003) FREQ,DELTAT
      RETURN
C
C
   30 JUMP=3
      TSTOP=TMX2
      FREQ=TMX2 - TMX1
      FREQ=DMIN1(FREQ,FSAVE)
      DELTAT=DMIN1(FREQ/4.D1,DSAVE)
      LSAVE=1
      SIMPX=SIMPX + FREQ*CMX
      TS=DMOD(TSTOP,8.64D4)
      TS=HMSOUT(TS)
      WRITE(6,10001) TS
      WRITE(6,10003) FREQ,DELTAT
      IF(NPULSE.LE.0.OR.TSTOP.LE.TSAVE) RETURN
      TS=DMOD(TSAVE,8.64D4)
      TSAVE=TSAVE + FSAVE
      TS1=DMOD(TSAVE,8.64D4)
      WRITE(6,10004) TS,TS1
      RETURN
C
C
   40 IF(TIME.LT.TMX2) RETURN
      JUMP=1
      NPULSE=NPULSE - 1
      ISW=0
      FREQ=FSAVE
      DELTAT=DSAVE
      TSTOP=TSAVE
      ACNTRL=0
      LSAVE=1
      IF(NPULSE.EQ.0) IATTDE=0
      TS=DMOD(TSTOP,8.64D4)
      TS=HMSOUT(TS)
      WRITE(6,10002) TS
      WRITE(6,10003) FREQ,DELTAT
      RETURN
C
C
10000 FORMAT('0',10X,'ATTITUDE CONTROL ON FOR PULSE ',I3/11X,
     .               'INTEGRATING TO LEADING EDGE OF PULSE  ',F10.3)
C
10001 FORMAT('0',10X,'INTEGRATING TO TRALING EDGE OF PULSE  ',F10.3)
C
10002 FORMAT('0',10X,'ATTITUDE CONTROL OFF'/11X,
     .               'CONTINUING PROBLEM TO  ',F10.3)
C
10003 FORMAT('0',10X,'WITH A PRINT FREQUENCY OF',F8.3/11X,
     .               'AND DELTA-TIME EQUAL TO',G20.8)
C
10004 FORMAT('0',30X,'THE STOP TIME FOR THIS RUN HAS BEEN CHANGED FROM '
     .              ,F9.3,' TO ',F9.3/'0','THE TRAILING EDGE OF THE ',
     .                                    'LAST PULSE WAS GREATER THAN '
     .                                   ,'THE PROBLEM TIME')
C
C
      END


module switch_mod
contains

!
!==============================================================

!  subroutine sort_bundled1bops
!  by CWJ @ SDSU 10/2011
!
!  based on subroutine sort_blocksPN_states
!  by WEO @ LLNL - 9/2011
!
!  sorts jumps for OpenMP application of PN
!  renamed from sort_bundle1bops in 7.7.9
!
!  CALLED BY:
!       main routine
!
!  CALLS: subroutine sort1bjumps
!
subroutine sort_bundled_jumps
   use sectors
   use jumpNbody
   use jump3body
   use precisions
   use basis
   use nodeinfo
!   use distrinfo
   use verbosity
   use opbundles
   use nodeinfo
   use flagger
   use bmpi_mod
   implicit none

   integer(8) :: j

   integer(8) :: npjmps, nnjmps, startp, startn
   integer    :: ibundle
   integer    :: iprocs, procstart,procstop

!........ OPTION TO SIMULATE MPI ON A SINGLE "CORE".....

  if((simulateMPI .and. nproc ==1) .or. .not.restrictjumps)then
      procstart = 0
      procstop  = nprocs -1
  else
      procstart = iproc
      procstop  = iproc
  end if

  do iprocs = procstart,procstop
     do ibundle = opbundlestart(iprocs), opbundleend(iprocs)

		 select case (opbundle(ibundle)%optype )
 !     if(opbundle(ibundle)%optype == 'PN')then
 !............................................................................. PN
            case ('PN')
               startp = opbundle(ibundle)%pxstart-1
               startn = opbundle(ibundle)%nsortstart-1
               npjmps = opbundle(ibundle)%pxend -startp
               nnjmps = opbundle(ibundle)%nsortend -startn
!--------------------   Sort proton jump states on final SD, p1b_fsd
!--------------------   Order them to enable OpenMP for the forward application of H_pn
               if(dosortjumps)then

!				   if(opbundle(ibundle)%hchar/='b')then

				   call sort1bjumps(npjmps,p1b_isd(startp+1),p1b_fsd(startp+1),              &
                       p1b_cop(startp+1),p1b_dop(startp+1),                     &
                       p1b_phase(startp+1))

!--------------------   Sort neutron jump states on INITIAL SD, n1b_isd
!--------------------   Order them to enable OpenMP for the backward application of H_pn;
!
! NOTE BY CWJ: However, do we need to sort these every time?
!

                call sort1bjumps(nnjmps,n1b_fsd(startn+1),n1b_isd(startn+1),              &
                       n1b_cop(startn+1),n1b_dop(startn+1),                     &
                       n1b_phase(startn+1))

   !--------------------   Sort neutron jump states on INITIAL SD, n1b_isd
   !--------------------   Order them to enable OpenMP for the backward application of H_pn;
   !
   ! NOTE BY CWJ: However, do we need to sort these every time?
   !

              end if
!............................................................................. PPN
            case('PPN')
!               if(opbundle(ibundle)%optype == 'PPN')then
                   startp = opbundle(ibundle)%pxstart-1
                startn = opbundle(ibundle)%nsortstart-1
                npjmps = opbundle(ibundle)%pxend -startp
                nnjmps = opbundle(ibundle)%nsortend -startn
!--------------------   Sort proton jump states on final SD, p1b_fsd
!--------------------   Order them to enable OpenMP for the forward application of H_pn
                if(dosortjumps)call sort2bjumps(npjmps,p2b_isd(startp+1),p2b_fsd(startp+1),              &
                       p2b_cop(startp+1),p2b_dop(startp+1),                     &
                       p2b_phase(startp+1))

!--------------------   Sort neutron jump states on final SD, n1b_isd
!--------------------   Order them to enable OpenMP for the backward application of H_pn;
!
! NOTE BY CWJ: However, do I need to sort these every time?
!
                if(dosortjumps)call sort1bjumps(nnjmps,n1b_fsd(startn+1),n1b_isd(startn+1),              &
                       n1b_cop(startn+1),n1b_dop(startn+1),                     &
                       n1b_phase(startn+1))
!      end if
!............................................................................. PNN
            case('PNN')
!      if(opbundle(ibundle)%optype == 'PNN')then
                startp = opbundle(ibundle)%pxstart-1
                startn = opbundle(ibundle)%nsortstart-1
                npjmps = opbundle(ibundle)%pxend -startp
                nnjmps = opbundle(ibundle)%nsortend -startn
!--------------------   Sort proton jump states on final SD, p1b_fsd
!--------------------   Order them to enable OpenMP for the forward application of H_pn
                if(dosortjumps)call sort1bjumps(npjmps,p1b_isd(startp+1),p1b_fsd(startp+1),              &
                       p1b_cop(startp+1),p1b_dop(startp+1),                     &
                       p1b_phase(startp+1))

!--------------------   Sort neutron jump states on final SD, n1b_isd
!--------------------   Order them to enable OpenMP for the backward application of H_pn;
!
! NOTE BY CWJ: However, do I need to sort these every time?
!

                if(dosortjumps)call sort2bjumps(nnjmps,n2b_fsd(startn+1),n2b_isd(startn+1),              &
                       n2b_cop(startn+1),n2b_dop(startn+1),                     &
                       n2b_phase(startn+1))

!      end if
!............................................................................. NN; added in 7.6.1
            case('NX')            ! I'm turning this off with a dummy optype, doesn't speed up

!                startn = opbundle(ibundle)%nsortstart-1
 !               nnjmps = opbundle(ibundle)%nsortend -startn
                startn = opbundle(ibundle)%nsortstart-1
                nnjmps = opbundle(ibundle)%nsortend -startn
! 				print*, ' Sorting on NN ',iproc,dosortjumps,startn,nnjmps,size(n2b_fsd)

!--------------------   Sort neutron jump states on final SD, n1b_isd
!--------------------   Order them to enable OpenMP for the backward application of H_pn;
!
! NOTE BY CWJ: However, do I need to sort these every time?
!
!print*,iproc,' SORRRTINGGGG ',startn,nnjmps,ibundle

                if(dosortjumps)call sort2bjumps1op(nnjmps,n2b_fsd(startn+1),n2b_isd(startn+1),              &
                       n2b_op(startn+1), n2b_phase(startn+1))

!............................................................................. PP; added in 7.6.1
			case('PP')  ! I'm turning this off with a dummy optype, doesn't speed up
				startp = opbundle(ibundle)%pxstart-1
			    npjmps = opbundle(ibundle)%pxend -startp
!--------------------   Sort proton jump states on final SD, p1b_fsd
!--------------------   Order them to enable OpenMP for the forward application of H_pn
			    if(dosortjumps)then
!					if(opbundle(ibundle)%hchar=='b')then
					   call sort2bjumps1op(npjmps,p2b_fsd(startp+1),p2b_isd(startp+1),              &
					                          p2b_op(startp+1),  p2b_phase(startp+1))
!					else
 !					   call sort2bjumps1op(npjmps,p2b_isd(startp+1),p2b_fsd(startp+1),              &
! 					                          p2b_op(startp+1),  p2b_phase(startp+1))

!					end if
				end if

			case default    ! do nothing

        end select
   end do  ! ibundle
 end do  ! iprocs

end subroutine sort_bundled_jumps

!
!
! Use shell sort to sort jumps.  The shell sort has
! the nice property that it is easy to thread
! not quite as fast for large arrays as qsort, but bulletproof.
! Previous qsort attempt was going out of bounds in rare circumstances.
!
! sorted on "x1b_fsd"
!
! CALLED BY: sort_bundled1bops
!
! CALLS: sort1bjumps_ins
!
subroutine sort1bjumps(ndim,x1b_isd,x1b_fsd,x1b_cop,x1b_dop,x1b_phase)
   use nodeinfo
   use precisions
   implicit none
   ! arguments
   integer(kind=8), intent(in) :: ndim
   integer(kind=basis_prec), intent(inout) :: x1b_isd(ndim), x1b_fsd(ndim)
   integer(kind=2), intent(inout) :: x1b_cop(ndim), x1b_dop(ndim)
   integer(kind=1), intent(inout) :: x1b_phase(ndim)
   ! locals
   integer(kind=basis_prec) :: off, h, i, k
   logical :: sorted
   ! For reasonable sized arrays a shell sort is  quite fast and is very simple
   ! We can also easily implement OMP on the inner loop
   ! shell sort starts with big strides and finishes with swaps
   ! should generate more strides or do dynamically.  See wikipedia article on shell sort
   ! I extended Sedgwick's table with Floor[2.25 a_{n-1}] + 1
   integer(kind=8) :: strides(28) = (/ &
      23422578909_8, 10410035071_8, 4626682254_8, 2056303224_8, &
      913912544_8, 406183353_8, 180525935_8, 80233749_8, &
      35659463_8, 15848650_8, 7043844_8, 3130597_8, &
      1391376_8, 463792_8, 198768_8, 86961_8, &
      33936_8, 13776_8, 4592_8, 1968_8, &
      861_8, 336_8, 112_8, 48_8, &
      21_8, 7_8, 3_8, 1_8/)
   integer(kind=8) :: stride

   do k=1, SIZE(strides,1)
      stride = strides(k)
      if(stride > ndim) cycle
      ! only off should be private
!$OMP PARALLEL DEFAULT(SHARED) PRIVATE(off)
!$OMP DO SCHEDULE(STATIC)
      do off=0, stride-1
         call sort1bjumps_ins(off,stride,ndim,x1b_isd,x1b_fsd,x1b_cop,x1b_dop,x1b_phase)
      end do
!$OMP END DO
!$OMP END PARALLEL
   end do

   ! check that sort worked
   sorted = .true.
   do i = 2, ndim
      if(x1b_fsd(i-1) > x1b_fsd(i))then
         sorted=.false.
         exit
      end if
   end do
   if(.not. sorted) then
      print *, "iproc=", iproc, ", sort1bjumps failed"
      stop 1 ! has msg
   end if
end subroutine sort1bjumps
!
!
! Perform an insertion sort with a stride and an offset
! Initial strides will be large
!
! CALLED BY: sort1bjumps
!
subroutine sort1bjumps_ins(off,stride, ndim,x1b_isd,x1b_fsd,x1b_cop,x1b_dop,x1b_phase)
   use nodeinfo
   use precisions
   implicit none
   ! arguments
   integer(kind=8), intent(in) :: off, stride, ndim
   integer(kind=basis_prec), intent(inout) :: x1b_isd(ndim), x1b_fsd(ndim)
   integer(kind=2), intent(inout) :: x1b_cop(ndim), x1b_dop(ndim)
   integer(kind=1), intent(inout) :: x1b_phase(ndim)
   ! locals
   integer(kind=basis_prec) :: s_isd, s_fsd
   integer(kind=2) :: s_cop, s_dop
   integer(kind=1) :: s_phase
   integer(kind=8) :: i, j, k

   ! scan array with lookback of stride for comparison
   do j = off+stride+1, ndim, stride
      s_isd = x1b_isd(j)
      s_fsd = x1b_fsd(j) ! sorting key
      s_cop = x1b_cop(j)
      s_dop = x1b_dop(j)
      s_phase = x1b_phase(j)
      k = j
      i = k - stride
      do while(i > 0)
         if(x1b_fsd(i) <= s_fsd) exit
         x1b_isd(k) = x1b_isd(i)
         x1b_fsd(k) = x1b_fsd(i)
         x1b_cop(k) = x1b_cop(i)
         x1b_dop(k) = x1b_dop(i)
         x1b_phase(k) = x1b_phase(i)
         k = i
         i = i - stride
      end do
      x1b_isd(k) = s_isd
      x1b_fsd(k) = s_fsd
      x1b_cop(k) = s_cop
      x1b_dop(k) = s_dop
      x1b_phase(k) = s_phase
   end do
end subroutine sort1bjumps_ins

!==============================================================
!  subroutine switch
!  by WEO @ LLNL - 9/2011
!
!  SUBROUTINES CALLED:
!   switchi4
!   switchi2
!   switchi1
!
subroutine switch(idim,i1,i2,iarr1,iarr2,iarr3,iarr4,iarr5)
   use precisions
   implicit none

   integer(kind=8) :: idim, i1, i2
   integer(kind=basis_prec) :: iarr1(idim),iarr2(idim)
   integer(kind=2) :: iarr3(idim),iarr4(idim)
   integer(kind=1) :: iarr5(idim)

   call switchibp(idim,i1,i2,iarr1)
   call switchibp(idim,i1,i2,iarr2)
   call switchi2(idim,i1,i2,iarr3)
   call switchi2(idim,i1,i2,iarr4)
   call switchi1(idim,i1,i2,iarr5)

   return

end subroutine switch

!==============================================================
!  subroutine switch1
!  by WEO @ LLNL - 9/2011
!
!  SUBROUTINES CALLED:
!  switchi4
!  switchi1

subroutine switch2(idim,i1,i2,iarr1,iarr2,iarr3,iarr5)
   implicit none
   integer(kind=8) :: idim, i1, i2
   integer(kind=4) :: iarr1(idim),iarr2(idim)
   integer(kind=4) :: iarr3(idim)
!   real(kind=4)    :: xarr4(idim)
   integer(kind=1) :: iarr5(idim)

   call switchi4(idim,i1,i2,iarr1)
   call switchi4(idim,i1,i2,iarr2)
   call switchi4(idim,i1,i2,iarr3)
!   call switchr4(idim,i1,i2,xarr4)
   call switchi1(idim,i1,i2,iarr5)

   return

end subroutine switch2

subroutine switchi4(idim,i1,i2,iarray)
   use precisions
   implicit none
   integer(kind=8) :: idim, i1, i2
   integer(kind=4) :: iarray(idim)
   integer(kind=4) :: itemp

   itemp = iarray(i2)
   iarray(i2) = iarray(i1)
   iarray(i1) = itemp
   return
end subroutine switchi4

subroutine switchibp(idim,i1,i2,iarray)
   use precisions
   implicit none
   integer(kind=8) :: idim, i1, i2
   integer(kind=basis_prec) :: iarray(idim)
   integer(kind=8) :: itemp

   itemp = iarray(i2)
   iarray(i2) = iarray(i1)
   iarray(i1) = itemp
   return
end subroutine switchibp

subroutine switchr4(idim,i1,i2,xarray)
   implicit none
   integer(kind=8) :: idim, i1, i2
   real(kind=4)    :: xarray(idim)
   real(kind=4)    :: xtemp

   xtemp = xarray(i2)
   xarray(i2) = xarray(i1)
   xarray(i1) = xtemp
   return
end subroutine switchr4

subroutine switchi2(idim,i1,i2,iarray)
   implicit none
   integer(kind=8) :: idim, i1, i2
   integer(kind=2) :: iarray(idim)
   integer(kind=2) :: itemp

   itemp = iarray(i2)
   iarray(i2) = iarray(i1)
   iarray(i1) = itemp
   return
end subroutine switchi2

subroutine switchi1(idim,i1,i2,iarray)
   implicit none
   integer(kind=8) :: idim, i1, i2
   integer(kind=1) :: iarray(idim)
   integer(kind=1) :: itemp

   itemp = iarray(i2)
   iarray(i2) = iarray(i1)
   iarray(i1) = itemp
   return
end subroutine switchi1

!==============================================================
!   set_bundledXY_threadstart
!  modified by CWJ @ SDSU - 11/2011
!
!  based on subroutine set_blocksPN_start
!  by WEO @ LLNL - 9/2011
!
!  sets start (and stop) for OpenMP threads for PN application
!
! CALLED BY: main routine
!
subroutine set_bundledXY_threadstart

   use sectors
   use jumpNbody
   use precisions
   use basis
   use nodeinfo
 ! use distrinfo
   use verbosity
   use opbundles
   use nodeinfo
   use flagger
   use jumplimits
   use bmpi_mod
   implicit none

   integer(kind=8) :: i, j
   integer :: k  ! for threads
   integer(kind=8) npjmps, nnjmps, startp, startn
   integer(kind=8) :: npjmpsf, npjmpsb
   integer(kind=8) :: startp1

   integer(8) :: num_sd
   integer(8) ::  min_num, max_num
   integer(8) :: iavg
   integer    :: ithread
   integer(8) :: sumj
   real(kind=8) :: avg, sdavg, sdvar
   integer(8) :: tot_jmps
   integer ibundle
   real eff, eff_avg, tot

   integer :: num_threads

   integer :: omp_get_num_threads
   integer(basis_prec),pointer :: pXb_fsd(:), nYb_isd(:)

   integer :: procstart,procstop,iprocs
   integer :: aerr
   if(iproc==0)print*,' SORTING THREADS '

!$omp parallel shared(num_threads)
   num_threads = omp_get_num_threads()
!$omp end parallel

   eff_avg = 0.0
   tot_jmps = 0

!........ OPTION TO SIMULATE MPI ON A SINGLE "CORE".....
  if((simulateMPI .and. nproc ==1) .or. .not. restrictjumps)then
      procstart = 0
      procstop  = nprocs -1
  else
      procstart = iproc
      procstop  = iproc
  end if

  do iprocs = procstart,procstop
     do ibundle = opbundlestart(iprocs), opbundleend(iprocs)

      if(opbundle(ibundle)%optype == 'PN' .or. &
          opbundle(ibundle)%optype == 'PPN' &
         .or. opbundle(ibundle)%optype == 'PNN')then

          select case( opbundle(ibundle)%optype )

             case ('PN')
                pXb_fsd => p1b_fsd
                nYb_isd => n1b_isd

             case ('PPN')
                pXb_fsd => p2b_fsd
                nYb_isd => n1b_isd

             case ('PNN')
                pXb_fsd => p1b_fsd
                nYb_isd => n2b_isd
             case default
                print *, "bad bun type ", opbundle(ibundle)%optype
                call printstacktrace
                stop 1 ! has msg
          end select

          startp = opbundle(ibundle)%pxstart-1
          startn = opbundle(ibundle)%nxstart-1
          npjmps = opbundle(ibundle)%pxend -startp
          nnjmps = opbundle(ibundle)%nxend -startn
          if(.not. allocated(opbundle(ibundle)%startp_thread)) then
             allocate(opbundle(ibundle)%startp_thread(0:num_threads), stat=aerr)
             if(aerr /= 0) call memerror("set_bundledXY_threadstart 1")
          end if
          if(.not. allocated(opbundle(ibundle)%startn_thread)) then
             allocate(opbundle(ibundle)%startn_thread(0:num_threads), stat=aerr)
             if(aerr /= 0) call memerror("set_bundledXY_threadstart 2")
          end if

!--------   Set up blocks for protons - based on initial p1b_fsd
!--------   Used for backward application of H_pn

!---  Get data for averages, average num/thread, etc
          num_sd = 1
          sumj = 0
          sdavg = 0.0
          sdvar = 0.0
          do j = startp + 2, startp + npjmps
               if(pXb_fsd(j) == pXb_fsd(j-1))then
                   sumj = sumj + 1
               else
                   sdavg = sdavg + real(sumj)
                   sdvar = sdvar + real(sumj)**2
                   sumj = 0
                   num_sd = num_sd + 1
               end if
           end do

           sdavg = sdavg/real(num_sd)
           sdvar = sdvar/real(num_sd)
           sdvar = sqrt(sdvar - sdavg**2)
           avg = real(npjmps)/real(num_threads)
           iavg = int(avg, 8)
           opbundle(ibundle)%startp_thread(0:num_threads-1) = 0
           ithread = 0
           sumj = 0
           opbundle(ibundle)%startp_thread(ithread) = startp

!  ----   Do appropriate break up for forward direction

           do j = startp + 2, startp + npjmps
               if(pXb_fsd(j) == pXb_fsd(j-1))then
                   sumj = sumj + 1
               else
                   if(ithread == num_threads - 1) then
                      sumj = sumj +1
                   else
                       if(sumj + sdavg/2 < iavg)then   ! See if current sum is too close to the average
               	            sumj = sumj + 1
                       else                    ! if exceeds, so let's stop
                           ithread = ithread + 1
                           sumj = 0
                           opbundle(ibundle)%startp_thread(ithread) = j - 1
                       end if
                   end if
               end if
            end do  ! j

            do k = ithread+1, num_threads
                opbundle(ibundle)%startp_thread(k) = startp + npjmps
            end do   ! k

!------ Set up blocks for neutrons - based on initial n1b_isd
!------  Used for backward application of H_pn

             num_sd = 1
             sumj = 0
             sdavg = 0.0
             sdvar = 0.0
             do j = startn + 2, startn + nnjmps
                  if(nYb_isd(j) == nYb_isd(j-1))then
                    sumj = sumj + 1
                  else
                    sdavg = sdavg + real(sumj)
                    sdvar = sdvar + real(sumj)**2
                    sumj = 0
                    num_sd = num_sd + 1
                  end if
              end do  ! j

              sdavg = sdavg/real(num_sd)
              sdvar = sdvar/real(num_sd)
              sdvar = sqrt(sdvar - sdavg**2)
              avg = real(nnjmps)/real(num_threads)
              iavg = int(avg, 8)
              opbundle(ibundle)%startn_thread(0:num_threads-1) = 0
              ithread = 0
              sumj = 0
              opbundle(ibundle)%startn_thread(ithread) = startn
               do j = startn + 2, startn + nnjmps

                   if(nYb_isd(j) == nYb_isd(j-1))then
                       sumj = sumj + 1
                   else
                       if(ithread == num_threads - 1) then
                           sumj = sumj + 1
                       else
                           if(sumj + sdavg/2 < iavg)then   ! See if current sum is too close to the average
               	              sumj = sumj + 1
                            else             ! if exceeds, so let's stop
                              ithread = ithread + 1
                              sumj = 0
                              opbundle(ibundle)%startn_thread(ithread) = j - 1
                            end if
                       end if
                    end if
              end do ! j

              do k = ithread+1, num_threads
                   opbundle(ibundle)%startn_thread(k) = startn + nnjmps
              end do  !k
              k = 0

              do j = 1,num_threads
                  if( opbundle(ibundle)%startp_thread(j) > opbundle(ibundle)%startp_thread(j-1) )k=k+1
              end do
              opbundle(ibundle)%numpthreads = k
              k = 0

              do j = 1,num_threads
                  if( opbundle(ibundle)%startn_thread(j) > opbundle(ibundle)%startn_thread(j-1) )k=k+1
              end do
              opbundle(ibundle)%numnthreads = k

      tot_jmps = tot_jmps + npjmps

      end if

   end do  ! ibundle
  end do   ! iprocs

!   eff_avg = eff_avg/real(tot_jmps)
!   write(6,*)'Average efficiency =',eff_avg

end subroutine set_bundledXY_threadstart

!==============================================================

!  subroutine sort2bjumps
!  by WEO @ LLNL - 9/2011
!!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!------   Try quick-sort algorithm isted of straight insertion        +
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

!    ALSO needed to introduce "switch2b" to get this right
!
!  SUBROUTINES CALLED
!     switch2b

subroutine sort2bjumps(ndim, x2b_isd, x2b_fsd, x2b_cop,x2b_dop,x2b_phase)
   use bmpi_mod
   use precisions
   implicit none
!---   Data passed in
   integer(kind=8) :: ndim
   integer(kind=basis_prec) :: x2b_isd(ndim), x2b_fsd(ndim)
   integer(kind=4) :: x2b_cop(ndim)
   integer(kind=4) :: x2b_dop(ndim)
   integer(kind=1) :: x2b_phase(ndim)

!----  Internal data
   integer(kind=8) :: m, nstack
   parameter (m=7,nstack=50)
   integer(kind=8) :: i, ir, j, k, l, istack(nstack)
   integer(kind=4) :: jstack
   integer(kind=basis_prec) :: isd, fsd
   integer(kind=4) :: cop, dop
   integer(kind=1) :: phase

   logical sorted
!.......... TEST IF ALREADY SORTED......
   sorted = .true.
   do i = 2,ndim
      if(x2b_fsd(i-1) > x2b_fsd(i))then
         sorted=.false.
         exit
      end if
   end do
   if(sorted)return
!...................................

   jstack=0
   l=1
   ir=ndim
1  if(ir-l.lt.M)then
      do 12 j=l+1,ir
!        a=x1b_fsd(j)
         isd = x2b_isd(j)
         fsd = x2b_fsd(j)
         cop = x2b_cop(j)
         dop = x2b_dop(j)
         phase = x2b_phase(j)
         do 11 i=j-1,1,-1
            if(x2b_fsd(i).le.fsd)goto 2
            x2b_fsd(i+1)=x2b_fsd(i)
            x2b_isd(i+1)=x2b_isd(i)
            x2b_cop(i+1)=x2b_cop(i)
            x2b_dop(i+1)=x2b_dop(i)
            x2b_phase(i+1)=x2b_phase(i)
11       continue
         i=0
2        x2b_fsd(i+1)=fsd
         x2b_isd(i+1)=isd
         x2b_cop(i+1)=cop
         x2b_dop(i+1)=dop
         x2b_phase(i+1)=phase
12    continue
      if(jstack.eq.0)return
      ir=istack(jstack)
      l=istack(jstack-1)
      jstack=jstack-2
   else
      k=(l+ir)/2

      call switch2b(ndim,k,l+1,x2b_isd,x2b_fsd,x2b_cop,x2b_dop,x2b_phase)

      if(x2b_fsd(l+1).gt.x2b_fsd(ir))then
         call switch2b(ndim,ir,l+1,x2b_isd,x2b_fsd,x2b_cop,x2b_dop,x2b_phase)
      end if
      if(x2b_fsd(l).gt.x2b_fsd(ir))then
         call switch2b(ndim,ir,l,x2b_isd,x2b_fsd,x2b_cop,x2b_dop,x2b_phase)
      end if
      if(x2b_fsd(l+1).gt.x2b_fsd(l))then
         call switch2b(ndim,l,l+1,x2b_isd,x2b_fsd,x2b_cop,x2b_dop,x2b_phase)
      end if
      i=l+1
      j=ir
      isd = x2b_isd(l)
      fsd = x2b_fsd(l)
      cop = x2b_cop(l)
      dop = x2b_dop(l)
      phase = x2b_phase(l)
!      a=x1b_fsd(l)
3     continue
      i=i+1
      if(x2b_fsd(i).lt.fsd)goto 3
!       if(x1b_fsd(i).lt.a)goto 3
4     continue
      j=j-1
      if(x2b_fsd(j).gt.fsd)goto 4
!        if(x1b_fsd(j).gt.a)goto 4
      if(j.lt.i)goto 5
      call switch2b(ndim,j,i,x2b_isd,x2b_fsd,x2b_cop,x2b_dop,x2b_phase)
      goto 3
5     x2b_fsd(l)=x2b_fsd(j)
      x2b_isd(l)=x2b_isd(j)
      x2b_cop(l)=x2b_cop(j)
      x2b_dop(l)=x2b_dop(j)
      x2b_phase(l)=x2b_phase(j)
      x2b_fsd(j)=fsd
      x2b_isd(j)=isd
      x2b_cop(j)=cop
      x2b_dop(j)=dop
      x2b_phase(j)=phase
!         x1b_fsd(j)=a
      jstack=jstack+2
      if(jstack.gt.NSTACK) then
         print *, 'NSTACK too small in sort'
         stop 1
      end if
      if(ir-i+1.ge.j-l)then
         istack(jstack)=ir
         istack(jstack-1)=i
         ir=j-1
      else
         istack(jstack)=j-1
         istack(jstack-1)=l
         l=i
      endif
   end if
   goto 1
   return
end subroutine sort2bjumps
!==============================================================

!  subroutine sort2bjumps
!  by WEO @ LLNL - 9/2011
!  modified in 7.6.1 by CWJ@SDSU
!
!  only 1 kind of operator
!
!!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!------   Try quick-sort algorithm isted of straight insertion        +
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
!
!    ALSO needed to introduce "switch2b" to get this right
!
! CALLED BY:
!
!  SUBROUTINES CALLED
!     switch2b

subroutine sort2bjumps1op(ndim, x2b_isd, x2b_fsd, x2b_op,x2b_phase)
   use bmpi_mod
   use precisions
   use nodeinfo
   implicit none
!---   Data passed in
   integer(kind=8) :: ndim
   integer(kind=basis_prec) :: x2b_isd(ndim), x2b_fsd(ndim)
   integer(kind=4) :: x2b_op(ndim)
   integer(kind=1) :: x2b_phase(ndim)

!----  Internal data
   integer(kind=8) :: m, nstack
   parameter (m=7,nstack=50)
   integer(kind=8) :: i, ir, j, k, l, istack(nstack)
   integer(kind=4) :: jstack
   integer(kind=basis_prec) :: isd, fsd
   integer(kind=4) :: op
   integer(kind=1) :: phase

   logical sorted
!.......... TEST IF ALREADY SORTED......
   sorted = .true.
   do i = 2,ndim
      if(x2b_fsd(i-1) > x2b_fsd(i))then
         sorted=.false.
         exit
      end if
   end do
   if(sorted)return
!...................................

   jstack=0
   l=1
   ir=ndim
1  if(ir-l.lt.M)then
      do 12 j=l+1,ir
!        a=x1b_fsd(j)
         isd = x2b_isd(j)
         fsd = x2b_fsd(j)
         op = x2b_op(j)
         phase = x2b_phase(j)
         do 11 i=j-1,1,-1
            if(x2b_fsd(i).le.fsd)goto 2
            x2b_fsd(i+1)=x2b_fsd(i)
            x2b_isd(i+1)=x2b_isd(i)
            x2b_op(i+1)=x2b_op(i)
            x2b_phase(i+1)=x2b_phase(i)
11       continue
         i=0
2        x2b_fsd(i+1)=fsd
         x2b_isd(i+1)=isd
         x2b_op(i+1)=op
         x2b_phase(i+1)=phase
12    continue
      if(jstack.eq.0)return
      ir=istack(jstack)
      l=istack(jstack-1)
      jstack=jstack-2
   else
      k=(l+ir)/2

      call switch2b1op(ndim,k,l+1,x2b_isd,x2b_fsd,x2b_op,x2b_phase)

      if(x2b_fsd(l+1).gt.x2b_fsd(ir))then
         call switch2b1op(ndim,ir,l+1,x2b_isd,x2b_fsd,x2b_op,x2b_phase)
      end if
      if(x2b_fsd(l).gt.x2b_fsd(ir))then
         call switch2b1op(ndim,ir,l,x2b_isd,x2b_fsd,x2b_op,x2b_phase)
      end if
      if(x2b_fsd(l+1).gt.x2b_fsd(l))then
         call switch2b1op(ndim,l,l+1,x2b_isd,x2b_fsd,x2b_op,x2b_phase)
      end if
      i=l+1
      j=ir
      isd = x2b_isd(l)
      fsd = x2b_fsd(l)
      op =  x2b_op(l)
      phase = x2b_phase(l)
!      a=x1b_fsd(l)
3     continue
      i=i+1
      if(x2b_fsd(i).lt.fsd)goto 3
!       if(x1b_fsd(i).lt.a)goto 3
4     continue
      j=j-1
      if(x2b_fsd(j).gt.fsd)goto 4
!        if(x1b_fsd(j).gt.a)goto 4
      if(j.lt.i)goto 5
      call switch2b1op(ndim,j,i,x2b_isd,x2b_fsd,x2b_op,x2b_phase)
      goto 3
5     x2b_fsd(l)=x2b_fsd(j)
      x2b_isd(l)=x2b_isd(j)
      x2b_op(l)=x2b_op(j)
      x2b_phase(l)=x2b_phase(j)
      x2b_fsd(j)=fsd
      x2b_isd(j)=isd
      x2b_op(j)=op
      x2b_phase(j)=phase
!         x1b_fsd(j)=a
      jstack=jstack+2
      if(jstack.gt.NSTACK) then
         print *, 'NSTACK too small in sort'
         stop 1
      end if
      if(ir-i+1.ge.j-l)then
         istack(jstack)=ir
         istack(jstack-1)=i
         ir=j-1
      else
         istack(jstack)=j-1
         istack(jstack-1)=l
         l=i
      endif
   end if
   goto 1
   return
end subroutine sort2bjumps1op

!==============================================================
!  subroutine switch
!  by WEO @ LLNL - 9/2011
!
subroutine switch2b(idim,i1,i2,iarr1,iarr2,iarr3,iarr4,iarr5)
   use precisions
   implicit none
   integer(kind=8) :: idim, i1, i2
   integer(kind=basis_prec) :: iarr1(idim),iarr2(idim)
   integer(kind=4) :: iarr3(idim),iarr4(idim)
   integer(kind=1) :: iarr5(idim)

   call switchibp(idim,i1,i2,iarr1)
   call switchibp(idim,i1,i2,iarr2)
   call switchi4(idim,i1,i2,iarr3)
   call switchi4(idim,i1,i2,iarr4)
   call switchi1(idim,i1,i2,iarr5)

   return

end subroutine switch2b

subroutine switch2b1op(idim,i1,i2,iarr1,iarr2,iarr3,iarr5)
   use precisions
   implicit none
   integer(kind=8) :: idim, i1, i2
   integer(kind=basis_prec) :: iarr1(idim),iarr2(idim)
   integer(kind=4) :: iarr3(idim)
   integer(kind=1) :: iarr5(idim)

   call switchibp(idim,i1,i2,iarr1)
   call switchibp(idim,i1,i2,iarr2)
   call switchi4(idim,i1,i2,iarr3)
   call switchi1(idim,i1,i2,iarr5)

   return

end subroutine switch2b1op

end module switch_mod