*----------------------------------------------------------------------*
      subroutine optc_prc_special2(me_grd,me_special,nspecial,
     &                            name_opt,w_shift,
     &                            nincore,xbuf1,xbuf2,xbuf3,lenbuf,
     &                            orb_info,op_info,str_info,strmap_info)
*----------------------------------------------------------------------*
*     experimental routine for testing special preconditioners
*     if nincore>1: xbuf1 contains the gradient vector on entry
*                   and should contain the preconditioned gradient
*                   on exit
*----------------------------------------------------------------------*
      implicit none

      include 'opdim.h'
      include 'stdunit.h'
      include 'mdef_operator_info.h'
      include 'def_orbinf.h'
      include 'hpvxseq.h'
      include 'def_graph.h'
      include 'def_strinf.h'
      include 'def_strmapinf.h'
      include 'def_reorder_info.h'
      include 'multd2h.h'
c      include 'ifc_input.h'
      include 'ifc_memman.h'
      include 'par_opnames_gen.h'

      integer, parameter ::
     &     ntest = 00

      integer, intent(in) ::
     &     nincore, lenbuf, nspecial
      type(me_list) ::
     &     me_grd
      type(me_list_array) ::
     &     me_special(nspecial)
      character(*), intent(in) ::
     &     name_opt
      real(8), intent(in) ::
     &     w_shift
      real(8), intent(inout), target ::
     &     xbuf1(lenbuf), xbuf2(lenbuf), xbuf3(lenbuf)
      type(orbinf), intent(in), target ::
     &     orb_info
      type(strinf),intent(in), target ::
     &     str_info
      type(strinf),intent(in), target ::
     &     strmap_info
      type(operator_info), intent(inout) ::
     &     op_info

      real(8) ::
     &     xdum
      logical ::
     &     ldum1, ldum2, ms_fix, fix_success
      integer ::
     &     ngrd, nblk_grd, nbmat, nxmat, nfmat,
     &     idxmsa, msa, msc, gama, gamc,  ngam,
     &     msc_max, msa_max, idxdis,  idx, idoff_grd,
     &     ncsub, nasub, nidx_p,
     &     nidx_cstr, nidx_astr, ms_cstr, ms_astr, gam_cstr, gam_astr,
     &     graph_cstr, graph_astr, len_cstr, len_astr, len_grd, ifree,
     &     idx_grd, idx_b, idx_x, mode,
     &     ngas, nspin, njoined, njoined_tmp, mstotal, gamtotal,
     &     iblk, iblk_off, idxms_bx, gam_bx, ld_bx, iblk_b,
     &     occ_b(ngastp,2),
     &     occ_blk_tmp(ngastp,2,2),
     &     rst_blk_tmp(2,orb_info%ngas,2,2,orb_info%nspin,2),
     &     rst_blk_reo(2,orb_info%ngas,2,2,orb_info%nspin,2)
      integer, target ::
     &     occ_blk_reo(ngastp,2,2),
     &     occ_blk_dag(ngastp,2,2),
     &     graph_blk_dag(ngastp,2,2)
      logical ::
     &     first, beyond_A, ca_reverse

      type(operator), pointer ::
     &     op_grd_reo
      type(me_list), pointer ::
     &     me_bmat, me_xmat, me_fmat, me_grd_reo
      type(graph), pointer ::
     &     graphs(:)
      type(reorder_info) ::
     &     reo_info

      integer ::
     &     f_hpvx(ngastp,2), msdst(ngastp,2), igamdst(ngastp,2),
     &     ioff_xsum(2*ngastp), nstr(2*ngastp), nincr(2*ngastp)

      integer, pointer ::
     &     hpvx_occ(:,:,:), idx_graph(:,:,:),
     &     ca_occ(:,:), occ_blk(:,:,:), rst_blk(:,:,:,:,:,:),
     &     igasca_restr(:,:,:,:,:,:),
     &     igas_restr(:,:,:,:,:),
     &     occ_blk_pnt(:,:,:), graph_blk_pnt(:,:,:),
     &     off_grd_d_gam_ms(:,:,:), len_grd_d_gam_ms(:,:,:),
     &     off_bx_gam_ms(:,:),
     &     mostnd(:,:,:), igamorb(:), idx_gas(:), ngas_hpv(:),
     &     hpvx_csub(:), hpvx_asub(:), occ_csub(:), occ_asub(:),
     &     graph_csub(:), graph_asub(:), msdis_c(:), msdis_a(:),
     &     idxmsdis_c(:), idxmsdis_a(:), gamdis_c(:), gamdis_a(:),
     &     len_str(:)
      real(8), pointer ::
     &     f_dia(:), xmat(:), bmat(:), xgrd_pnt(:), xgrd_buf(:),
     &     scrbuf(:)

      integer, external ::
     &     idxlist, iblk_occ, idx_oplist2, idx_mel_list, imltlist
      logical,external ::
     &     next_msgamdist2

      if (ntest.ge.100) then
        call write_title(lulog,wst_dbg_subr,'special preconditioner')
      end if

      if (nincore.ne.3)
     &     call quit(1,'optc_prc_special2',
     &     'currently: special preconditioning for nincore==3, only')

      if (nspecial.lt.1)
     &     call quit(1,'optc_prc_special2',
     &     'nspecial must be >= 1')

      me_bmat => me_special(1)%mel
      nbmat = me_bmat%len_op
      allocate(bmat(nbmat))
      ! should be open
      call vec_from_da(me_bmat%fhand,1,bmat,nbmat)

      beyond_A = me_bmat%op%name.ne.op_b_inv

      if (beyond_A) then
        if (nspecial.lt.3)
     &       call quit(1,'optc_prc_special2','nspecial must be >= 3')

        me_xmat => me_special(2)%mel
        nxmat = me_xmat%len_op

        allocate(xmat(nxmat))
        ! should be open as well
        call vec_from_da(me_xmat%fhand,1,xmat,nxmat)

        me_fmat => me_special(3)%mel
        nfmat = me_fmat%len_op

        allocate(f_dia(2*orb_info%ntoob))

        ! xtract diagonal
        call onedia_from_op(f_dia,xdum,me_fmat,.false.,orb_info)

      else
        allocate(xmat(1),f_dia(1))
      end if

      ngam = orb_info%nsym
      ngas = orb_info%ngas
      nspin = orb_info%nspin
      mostnd => orb_info%mostnd
      igamorb => orb_info%igamorb
      idx_gas => orb_info%idx_gas
      ngas_hpv => orb_info%ngas_hpv

      nblk_grd = me_grd%op%n_occ_cls
      njoined  = me_grd%op%njoined
      hpvx_occ => me_grd%op%ihpvca_occ
      igasca_restr => me_grd%op%igasca_restr
      idx_graph => me_grd%idx_graph
      ca_occ => me_grd%op%ica_occ
      mstotal = me_grd%mst
      gamtotal = me_grd%gamt
      graphs => str_info%g
      igas_restr => str_info%igas_restr

      ms_fix = me_grd%fix_vertex_ms
      do idx = 1, nspecial
        if(ms_fix.or.me_special(idx)%mel%fix_vertex_ms)then
          ms_fix = ms_fix.and.me_special(idx)%mel%fix_vertex_ms
          if(.not.ms_fix) call quit(1,'optc_prc_special2',
     &                              'fix ms or not?')
        endif
      enddo

c      if (njoined.ne.2)
c     &     call quit(1,'optc_prc_special',
c     &     'strange -- expected njoined==2')

      ! loop over occupations of GRD
      do iblk = 1, nblk_grd
        iblk_off = (iblk-1)*njoined

        if (ntest.ge.100) then
          idx_grd = me_grd%off_op_occ(iblk)+1
          len_grd = me_grd%len_op_occ(iblk)
          write(lulog,*) 'iblk = ',iblk
          write(lulog,*) 'gradient vector before:'
          write(lulog,*) xbuf1(idx_grd+1:idx_grd+len_grd)
        end if

        occ_blk =>
     &       hpvx_occ(1:ngastp,1:2,iblk_off+1:iblk_off+njoined)
        rst_blk =>
     &       igasca_restr(1:ngastp,1:ngas,1:2,1:2,1:nspin,
     &                             iblk_off+1:iblk_off+njoined)
c        len_grd_d_gam_ms =>
c     &       me_grd%len_op_gmox(iblk)%d_gam_ms
        off_grd_d_gam_ms =>
     &       me_grd%off_op_gmox(iblk)%d_gam_ms

        if (ntest.ge.100) then
          write(lulog,*) 'Now caring for GRD block: '
          call wrt_occ_n(lulog,occ_blk,njoined)
        end if

        call get_num_subblk(ncsub,nasub,
     &       hpvx_occ(1,1,iblk_off+1),njoined)

        if (ntest.ge.100)
     &       write(lulog,*) 'ncsub, nasub: ',ncsub, nasub

        mode = 0
        ca_reverse = .false.
        ! find the relevant block of B
        if (njoined.eq.2) then
          iblk_b = 1
        else if (njoined.eq.1) then
          if (name_opt.eq.op_cex.or.
     &        name_opt.eq.op_rp.or.
     &        name_opt(1:1).eq.'W') then  !for response
            mode = 1
            nidx_p = occ_blk(IPART,1,1)
            occ_b = 0
            occ_b(IPART,1) = 1
            occ_b(IPART,2) = 1
          else if (
     &        name_opt.eq.op_cexbar.or.
     &        name_opt.eq.op_lp.or.
     &        name_opt(1:1).eq.'Y') then  !for response
            mode = 1
            nidx_p = occ_blk(IPART,2,1)
            occ_b = 0
            occ_b(IPART,1) = 1
            occ_b(IPART,2) = 1
            ca_reverse = .true.
          else if (name_opt.eq.op_cexx) then
            mode = 2
            nidx_p = occ_blk(IPART,1,1)
            occ_b = 0
            occ_b(IPART,1) = 2
            occ_b(IPART,2) = 2
          else
            occ_b(1:ngastp,1) = occ_blk(1:ngastp,1,1)
            occ_b(1:ngastp,2) = occ_blk(1:ngastp,1,1)
          end if
          iblk_b = iblk_occ(occ_b,.false.,me_bmat%op,1)
          if (iblk_b.le.0)
     &         call quit(1,'optc_prc_special2',
     &         'did not find an appropriate block of B (precond)')
        else
          call quit(1,'optc_prc_special2',
     &         'gradient -- njoined > 2 ??')
        end if

        off_bx_gam_ms => me_bmat%off_op_gmo(iblk_b)%gam_ms

        ! special case: scalar:
        if (ncsub.eq.0.and.nasub.eq.0) then
          idx_grd = off_grd_d_gam_ms(1,1,1)+1
          idx_b   = off_bx_gam_ms(1,1)+1
          xbuf1(idx_grd) = xbuf1(idx_grd)/bmat(idx_b)
          cycle
        end if

        if (ncsub.ne.1.and.ncsub.ne.2.and.nasub.ne.1) then
          write(lulog,*) 'ncsub, nasub: ',ncsub,nasub
          call quit(1,'optc_prc_special2','this is not what I expected')
        end if

        if (njoined.eq.1.and.mode.ne.nidx_p) then

          call init_reo_info(reo_info)

          call set_reo_special(1,reo_info,mode)

          ! cheat get_reo_info: append zero block, so both
          ! reordered and original occupation have njoined==2
          occ_blk_tmp = 0
          rst_blk_tmp = 0
          occ_blk_tmp(1:ngastp,1:2,1) = occ_blk(1:ngastp,1:2,1)
          rst_blk_tmp(1:2,1:ngas,1:2,1:2,1:nspin,1)
     &         = rst_blk(1:2,1:ngas,1:2,1:2,1:nspin,1)

          ! post-processing
          occ_blk_reo = occ_blk_tmp
          call get_reo_info(ldum1,ldum2,
     &         occ_blk_reo,occ_blk_tmp,
     &         rst_blk_reo,rst_blk_tmp,
     &         2,
     &         reo_info,str_info,orb_info)

          ! set up operator and list for re-ordered block
          call add_operator('GRD_REO',op_info)
          idx = idx_oplist2('GRD_REO',op_info)
          op_grd_reo => op_info%op_arr(idx)%op
          call set_uop2(op_grd_reo,'GRD_REO',
     &         occ_blk_reo,1,2,(/0,0/),-1,orb_info)
c          call add_me_list('L_GRD_REO',op_info)
          call define_me_list('L_GRD_REO','GRD_REO',
     &         me_grd%absym,me_grd%casym,me_grd%gamt,
     &         me_grd%s2,me_grd%mst,.false.,
     &         -1,1,1,0,0,0,
     &         op_info,orb_info,str_info,strmap_info)
          idx = idx_mel_list('L_GRD_REO',op_info)
          me_grd_reo => op_info%mel_arr(idx)%mel

          len_grd = me_grd_reo%len_op
          ifree = mem_setmark('grd_reo')
          ifree = mem_alloc_real(xgrd_buf,len_grd,'reo_buf')
          xgrd_pnt => xgrd_buf

          ! make the buffer pointer point to the buffer
          if (me_grd_reo%fhand%buffered)
     &         call quit(1,'optc_prc_special2',
     &         'OK, adapt the hand-made buffering in this routine ...')
          me_grd_reo%fhand%buffered = .true.
          allocate(me_grd_reo%fhand%incore(1))
          me_grd_reo%fhand%incore(1) = 1
          me_grd_reo%fhand%buffer => xgrd_pnt

          if (me_grd%fhand%buffered)
     &         call quit(1,'optc_prc_special2',
     &         'OK, adapt the hand-made buffering in this routine ...')
          me_grd%fhand%buffered = .true.
          allocate(me_grd%fhand%incore(nblk_grd))
          me_grd%fhand%incore(1:nblk_grd) = 0
          me_grd%fhand%incore(iblk) = 1
          me_grd%fhand%buffer => xbuf1
          ! we must resort
          idoff_grd = 0
          call reo_op_wmaps_c(1d0,
     &         .false.,xdum,0,
     &         me_grd,me_grd_reo,
     &         .false.,.false.,
     &         iblk,1,
     &         idoff_grd,0,
     &         reo_info,
     &         str_info,strmap_info,orb_info)

          call get_num_subblk(ncsub,nasub,
     &       occ_blk_reo,2)
          occ_blk_pnt => occ_blk_reo
          idx_graph => me_grd_reo%idx_graph
          graph_blk_pnt => idx_graph(1:ngastp,1:2,1:2)
          njoined_tmp = 2
          off_grd_d_gam_ms =>
     &         me_grd_reo%off_op_gmox(1)%d_gam_ms
        else
c          if (.not.ca_reverse) then
            occ_blk_pnt =>
     &         hpvx_occ(1:ngastp,1:2,iblk_off+1:iblk_off+njoined)
            graph_blk_pnt => idx_graph(1:ngastp,1:2,
     &         iblk_off+1:iblk_off+njoined)
c          else
c            occ_blk_dag(1:ngastp,1,1:njoined) =
c     &           hpvx_occ(1:ngastp,2,iblk_off+1:iblk_off+njoined)
c            occ_blk_dag(1:ngastp,2,1:njoined) =
c     &           hpvx_occ(1:ngastp,1,iblk_off+1:iblk_off+njoined)
c            graph_blk_dag(1:ngastp,1,1:njoined) =
c     &           idx_graph(1:ngastp,2,iblk_off+1:iblk_off+njoined)
c            graph_blk_dag(1:ngastp,2,1:njoined) =
c     &           idx_graph(1:ngastp,1,iblk_off+1:iblk_off+njoined)
c            occ_blk_pnt   => occ_blk_dag
c            graph_blk_pnt => graph_blk_dag
c          end if
          njoined_tmp = njoined
          xgrd_pnt => xbuf1
        end if

        ! uses new ncsub/nasub if reordered
        allocate(hpvx_csub(ncsub),hpvx_asub(nasub),
     &           occ_csub(ncsub), occ_asub(nasub),
     &           graph_csub(ncsub), graph_asub(nasub),
     &           msdis_c(ncsub),  msdis_a(nasub),
     &           idxmsdis_c(ncsub),  idxmsdis_a(nasub),
     &           gamdis_c(ncsub), gamdis_a(nasub),
     &           len_str(ncsub+nasub))

        ! the same for reordered and un-reordered case...
        msc_max = ca_occ(1,iblk)
        msa_max = ca_occ(2,iblk)

        ! set HPVX and OCC info
        call condense_occ(occ_csub, occ_asub,
     &                    hpvx_csub,hpvx_asub,
     &                    occ_blk_pnt,njoined_tmp,hpvxblkseq)
        ! do the same for the graph info
        call condense_occ(graph_csub, graph_asub,
     &                    hpvx_csub,hpvx_asub,
     &                    graph_blk_pnt,
     &                                njoined_tmp,hpvxblkseq)

        ! loop over MS(A)
        idxmsa = 0
        msa_loop: do msa = msa_max, -msa_max, -2

          msc = msa + mstotal

          if (abs(msc).gt.msc_max) cycle msa_loop
          idxmsa = idxmsa+1

          gama_loop: do gama = 1, ngam

            gamc = multd2h(gama,gamtotal)

            if (ntest.ge.100)
     &           write(lulog,*) 'current MS(A), MS(C), GAM(A), GAM(C):',
     &                           msa, msc, gama, gamc

            idxdis = 0
            first = .true.
            distr_loop: do

              if (.not.next_msgamdist2(first,
     &             msdis_c,msdis_a,gamdis_c,gamdis_a,
     &             ncsub,nasub,
     &             occ_csub,occ_asub,
     &             msc,msa,gamc,gama,ngam,
     &             ms_fix,fix_success)) exit distr_loop

              first = .false.
c              if(ms_fix.and..not.fix_success)cycle distr_loop

              call ms2idxms(idxmsdis_c,msdis_c,occ_csub,ncsub)
              call ms2idxms(idxmsdis_a,msdis_a,occ_asub,nasub)

              call set_len_str(len_str,ncsub,nasub,
     &                         graphs,
     &                         graph_csub,idxmsdis_c,gamdis_c,hpvx_csub,
     &                         graph_asub,idxmsdis_a,gamdis_a,hpvx_asub,
     &                         hpvxseq,.false.)

              if (idxlist(0,len_str,ncsub+nasub,1).gt.0)
     &             cycle distr_loop

              idxdis = idxdis+1

c test -- special insert
              if (.false..and.njoined.eq.1) then

                if (mode.eq.nidx_p) then
                  idx = idxlist(IPART,hpvx_csub,ncsub,1)
                  if (idx.ne.1) stop '???'
                  idxms_bx  = idxmsdis_c(idx)
                  gam_bx = gamdis_c(idx)
                  ld_bx  = len_str(idx)
                  idx_b = off_bx_gam_ms(gam_bx,idxms_bx)+1
                  len_astr = len_str(2)
                  idx_grd = off_grd_d_gam_ms(idxdis,gama,idxmsa)+1
                  call optc_prc_test(xbuf1(idx_grd),
     &               xbuf2,xbuf3,bmat(idx_b),xmat(idx_b),ld_bx,len_astr)
                  cycle
                else
                  stop 'I cannot do this ...'
                end if

              end if

              ! Gamma and Ms of B and X
              idx = idxlist(IHOLE,hpvx_csub,ncsub,1)
              if (idx.le.0.and.njoined.eq.2)
     &             call quit(1,'optc_prc_special2','no HOLE??')
              if (njoined.eq.1.and..not.ca_reverse)
     &             idx = imltlist(IPART,hpvx_csub,ncsub,1)
              if (njoined.eq.1.and.ca_reverse)
     &             idx = imltlist(IPART,hpvx_asub,nasub,1)
              if (idx.le.0.or.idx.gt.2)
     &             call quit(1,'optc_prc_special2','strange')
              if (.not.ca_reverse) then
                idxms_bx  = idxmsdis_c(idx)
                gam_bx = gamdis_c(idx)
                ld_bx  = len_str(idx)
              else
                idxms_bx  = idxmsdis_a(idx)
                gam_bx = gamdis_a(idx)
                ld_bx  = len_str(ncsub+idx)
              end if

              if (ld_bx.le.0) cycle

              ! occupation, Gamma and Ms of C-string
              if (njoined.eq.2) then
                idx = idxlist(IPART,hpvx_csub,ncsub,1)
              else
                if (.not.ca_reverse)
     &               idx = imltlist(IPART,hpvx_csub,ncsub,1)
                if (     ca_reverse)
     &               idx = imltlist(IPART,hpvx_asub,nasub,1)
                if (idx.eq.2) then
                  idx = 1
                else
                  idx = 0
                end if
              end if
              if (idx.le.0) then
                nidx_cstr = 0
                ms_cstr = 0
                gam_cstr = 1
                len_cstr = 1
                graph_cstr = 1 ! dummy
              else
                if (.not.ca_reverse) then
                  nidx_cstr = occ_csub(idx)
                  ms_cstr   = msdis_c(idx)
                  gam_cstr  = gamdis_c(idx)
                  len_cstr = len_str(idx)
                  graph_cstr = graph_csub(idx)
                else
                  nidx_cstr = occ_asub(idx)
                  ms_cstr   = msdis_a(idx)
                  gam_cstr  = gamdis_a(idx)
                  len_cstr = len_str(ncsub+idx)
                  graph_cstr = graph_asub(idx)
                end if
              end if

              if (len_cstr.le.0) cycle

              ! occupation, Gamma and Ms of A-string
              ! idx = 1,  we know that for sure
              if (.not.ca_reverse) then
                nidx_astr = occ_asub(1)
                ms_astr   = msdis_a(1)
                gam_astr  = gamdis_a(1)
                len_astr = len_str(ncsub+1)
                graph_astr = graph_asub(1)
              else
                nidx_astr = occ_csub(1)
                ms_astr   = msdis_c(1)
                gam_astr  = gamdis_c(1)
                len_astr = len_str(1)
                graph_astr = graph_csub(1)
              end if

              if (len_astr.le.0) cycle

              ! offset of GRD
              idx_grd = off_grd_d_gam_ms(idxdis,gama,idxmsa)+1

              ! offset of appropriate block of B (and X)
              idx_b = off_bx_gam_ms(gam_bx,idxms_bx)+1
              idx_x = idx_b

              idx_b = off_bx_gam_ms(gam_bx,idxms_bx)+1
              idx_x = idx_b
              if (.not.beyond_A) idx_x = 1

              if (ld_bx.lt.len_cstr*len_astr) then
                scrbuf => xbuf3
              else
                allocate(scrbuf(ld_bx*ld_bx))
              end if

              call optc_prc_special2_inner
     &             (xgrd_pnt(idx_grd), beyond_A,njoined.eq.1
     &                 .and.nidx_cstr.gt.0, w_shift,
     &              xbuf2,scrbuf,bmat(idx_b),xmat(idx_x),f_dia,
     &              ld_bx,len_cstr, len_astr,
     &              nidx_cstr,ms_cstr,gam_cstr,
     &               igas_restr(1,1,1,1,graph_cstr),
     &               mostnd(1,1,idx_gas(IPART)),ngas_hpv(IPART),
     &              nidx_astr,ms_astr,gam_astr,
     &               igas_restr(1,1,1,1,graph_astr),
     &               mostnd(1,1,idx_gas(IHOLE)),ngas_hpv(IHOLE),
     &              igamorb,ngam,ngas)

              if (ld_bx.ge.len_cstr*len_astr) then
                deallocate(scrbuf)
              end if

            end do distr_loop

          end do gama_loop

        end do msa_loop

        if (njoined.eq.1.and.mode.ne.nidx_p) then

          call set_reo_special(2,reo_info,mode)

          ! post-processing
          occ_blk_tmp = occ_blk_reo
          call get_reo_info(ldum1,ldum2,
     &         occ_blk_tmp,occ_blk_reo,
     &         rst_blk_tmp,rst_blk_reo,
     &         2,
     &         reo_info,str_info,orb_info)

          ! we must sort back, as well
          idoff_grd = 0
          call reo_op_wmaps_c(1d0,
     &         .false.,xdum,0,
     &         me_grd_reo,me_grd,
     &         .false.,.false.,
     &         1,iblk,
     &         0,idoff_grd,
     &         reo_info,
     &         str_info,strmap_info,orb_info)

          ! clean up
          deallocate(me_grd%fhand%incore,
     &               me_grd_reo%fhand%incore)

          me_grd%fhand%buffered = .false.
          me_grd%fhand%incore => null()
          me_grd%fhand%buffer => null()

          me_grd_reo%fhand%buffered = .false.
          me_grd_reo%fhand%incore => null()
          me_grd_reo%fhand%buffer => null()

          call del_me_list('L_GRD_REO',op_info)
          call del_operator('GRD_REO',op_info)
          call dealloc_reo_info(reo_info)
        end if

        if (ntest.ge.100) then
          write(lulog,*) 'gradient vector afterwards:'
          write(lulog,*) xbuf1(idx_grd+1:idx_grd+len_grd)
        end if

      end do

      deallocate(f_dia,xmat,bmat)

      return
      end

      subroutine optc_prc_test(grd,
     &     buf1,buf2,bmat,xmat,lenp,lenh)

      implicit none

      integer, intent(in) ::
     &     lenp, lenh
      real(8), intent(in) ::
     &     bmat(lenp,lenp), xmat(lenp,lenp)
      real(8), intent(inout) ::
     &     buf1(lenp,lenh), buf2(lenp,lenh)
      real(8), intent(inout) ::
     &     grd(lenp,lenh)

      real(8), parameter ::
     &     thrsh = 1d-12

      real(8), pointer ::
     &     scr(:,:), umat(:,:), vtmat(:,:), wrk(:), singval(:)

      integer ::
     &     idx, jdx, kdx, info, lwrk

      lwrk=max(1024,lenp*max(lenh,lenp))
      allocate(scr(lenp,lenp),umat(lenp,lenp),vtmat(lenp,lenp),
     &     wrk(lwrk),singval(lenp))

      scr = bmat + 10*xmat

      call dgesvd('A','A',lenp,lenp,
     &     scr,lenp,singval,
     &     umat,lenp,vtmat,lenp,
     &     wrk,lwrk,info)

      do jdx = 1, lenh
        do idx = 1, lenp
          wrk(idx) = 0d0
          if (abs(singval(idx)).lt.thrsh) cycle
          do kdx = 1, lenp
            wrk(idx) = wrk(idx)+
     &           umat(kdx,idx)*grd(kdx,jdx)
          end do
          wrk(idx) = wrk(idx)/singval(idx)
        end do

        do idx = 1, lenp
          buf1(idx,jdx) = 0d0
          do kdx = 1, lenp
            buf1(idx,jdx) = buf1(idx,jdx) +
     &           vtmat(kdx,idx)*wrk(kdx)
          end do
        end do

      end do

c      call gaussj(scr,lenp,lenp)

c      do jdx = 1, lenh
c        do idx = 1, lenp
c          buf1(idx,jdx) = 0d0
c          do kdx = 1, lenp
c            buf1(idx,jdx) = buf1(idx,jdx)+
c     &           scr(kdx,idx)*grd(kdx,jdx)
c          end do
c        end do
c      end do

      grd = buf1

      deallocate(scr,wrk,umat,vtmat,singval)

      return
      end

      subroutine set_reo_special(iway,reo_info,np)

      implicit none

      include 'opdim.h'
      include 'def_reorder_info.h'

      type(reorder_info), intent(out) ::
     &     reo_info
      integer, intent(in) ::
     &     np, iway

      integer ::
     &     occ_shift(ngastp,2)

      reo_info%nvtx_contr = 2
      allocate(reo_info%nca_vtx(2))
      reo_info%nca_vtx(2) = 0
      reo_info%nreo = 1
      allocate(reo_info%reo(1))
      reo_info%reo(1)%idxsuper = 1          ! dummy
      reo_info%reo(1)%is_bc_result = .true. ! dummy
      reo_info%reo(1)%shift_i0 = .false.
      if (iway==1) then
        reo_info%reo(1)%from = 1
        reo_info%reo(1)%to   = 2
        reo_info%reo(1)%from_vtx = 1
        reo_info%reo(1)%to_vtx   = 2
      else
        reo_info%reo(1)%from = 2
        reo_info%reo(1)%to   = 1
        reo_info%reo(1)%from_vtx = 2
        reo_info%reo(1)%to_vtx   = 1
      end if
      occ_shift = 0
      occ_shift(IPART,1) = np
      reo_info%reo(1)%occ_shift = occ_shift

      return
      end


  function sigmat8 (sDCM, l, ms, mb, ksi, iks, t)

! ======================================================================
!
!     Choose cross section type and calculate cross section for
!     a given struck-nucleon rest frame kinetic energy.
!     l always 1 for photons; ms always 0; mb = baryon number.
!     mb may be 1 or 2.
!     ksi = 1 for n - n, p - p, pi+ - p & pi- - n.
!     ksi = 2 for n - p, pi+ - n & pi- - p.
!     ksi = 3 for pi0 - n, pi0 - p
!     iks = 0:   total cross section
!     iks = 1:   elastic cross section
!     iks = 2:   pion charge exchange cross section
!     iks = 3:   pion or gamma absorption cross section
!     iks = 4:   neutral pion production cross section
!     iks = 5:   charged pion production cross section
!     iks = 6:   target & projectile isospin change & neutral pion
!                production (9/11/97)
!     iks = 7:   total one-pion production cross section (3/15/99)
!     iks = 8:   delta production (by gamma) cross section
!
!   Called by: CHINEL POINTE TYPINT.
!
!   Calls: QINTS
!   CEM95 written by S. G. Mashnik
!
!   Edited by A. J. Sierk,  LANL  T-2  February-March, 1996.
!   Edited by AJS, July, 1997.
!   Edited by AJS, December, 1998.
!   Corrected by KKG 28.11.01
!   Modified by A. J. Sierk, LANL T-16  October, 2003.
!   Edited by AJS, LANL T-2, December, 2011.
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64
    use standardDCMParams, only: zro, two
    use standardDCMData,   only: icst, nsicst

    implicit none
    class(StandardDCM), intent(inout) :: sDCM
    integer(int32), intent(in   ) :: l
    integer(int32), intent(in   ) :: ms
    integer(int32), intent(in   ) :: mb
    integer(int32), intent(in   ) :: ksi
    integer(int32), intent(in   ) :: iks
    real(real64),   intent(in   ) :: t
    real(real64)                  :: sigmat8

    integer(int32) ::  ics, js, kns, nsjs

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

!   Factor with which to multiply deuteron absorption cross section to
!   get effective absorption cross section inside nucleus:
!   Corrected pi-0 absorption for factor of 2 historical error.
!   AJS; 12/16/98.
    real(real64), parameter :: absfct = 4.0_real64

!   Factor with which to multiply gamma absorption cross section to
!   get effective absorption cross section inside nucleus:
!   Corrected gamma absorption according to notice at tabulated data.
!   SGM 05/25/03:
    real(real64), parameter :: absfct2 = 5.0_real64

! ======================================================================
!  From bd2:
!     data icst /
!  Translation:total:|elas:   |total: |elas:  |total:  |elas:   |pi+ n or
!              p+p or|p+p or  |       |       |pi- p or|pi- p or|pi- p  |
!              n+n   |n+n     |p+n    |n+p    |pi+ n   |pi+ n   |SCX    |
!    &         210,    211,    220,    221,     120,     121,     122,
!                           | Absorp: |
!  Translation:total:|elas: |pi+ np:pp|p + p->|p + p->|p + n->|p + n->|
!            pi+ p or|pi+ p |pi- pp:np|p p pi0|p n pi+|p + n +|p + p +|
!            pi- n   |pi- n |pi- pn:nn|n + n->|n + n->|pi0    |pi-    |
!                           |pi+ nn:np|n n pi0|p n pi-
!    &         110,    111,    123,    214,     215,     224,    225,
!
!  Transl:   pi+ p->|pi+ p->|pi- p ->|pi- + p->|pi- + p->|gam + p|gam +p|
!         pi0 pi+ p |n +2pi+|2pi0 + n|p + pi- +|n pi- pi+|-> p + |-> n +|
!            pi- n->|pi- n->|pi+ n ->|pi0      |pi+ + n->| pi0   |pi+
!         pi0 pi- n |p +2pi-|2pi0 + p|         |p pi- pi+| (20)   | (21)
!    &         114,    115,    126,     124,      125,    10111,  10112,
!            Absorp:
!  Transl:   gam +  |gam + p |gam + p |gam + p |gam + p |gam + p|gam + p|
!            2N ->  |-> pi+ p|->pi0 p |->n pi+ |-> delta|-> N + |total  |
!   (absorp) 2N (22)|+ pi- 23|+ pi0 24|+ pi0 25|++ + pi-|2 pi 27| (28)  |
!    &       10113,   10115,  10114,   10116    10118,   10117,   10110/

!     data nsicst /
!                   |Absorp:  |  =0! |
!   Key:    pi+ p or|pi+ pn:pp|pi+ p:|pi+ p:|pi+ n:  |pi0 n |pi0 n  |
!            pi- n  |   or    |n 2pi0|N+ 2pi|N + 2pi | or   | or    |
!            SCX=0! |pi- pn:nn|pi- n:|pi- n:|pi- p:  |pi0 p |pi0 p  |
!                             |p 2pi0|N+ 2pi|N + 2pi |total |elastic|
!    &         112,    113,     116,   117,    127,    130,    131,
!                   |Absorp:  |
!   Key:     pi0+p: |pi0+pn:pn|pi0+p:|pi0+p:  |pi0+p:  |pi0+p: |p + p: |
!            pi+ + n|pi0+pp:pp|p 2pi0|p pi+pi-|n pi+pi0|N + 2pi| SCX   |
!            pi0+n: |pi0+np:np|pi0+n:|pi0+n:  |pi0+n:  |pi0+n: |n + n: |
!            pi- + p|pi0+nn:nn|n 2pi0|n pi+pi-|p pi-pi0|N + 2pi| = 0!  |
!    &         132,    133,     134,   135,     136,     137,    212,
!
!   Key:     p + p: |p+p;n+n |p + p->|n + p: |n + p:  |n + p: |n + p->|
!      pi absorption|chg exch|2N + pi| SCX   | Pion   |n p pi0|N N pi |
!            n + n: |+ pi0   |n + n->|       |absorp. |Same as|       |
!             = 0!  |  = 0!  |2N + pi| = 0!  | = 0!   |  224! |       |
!    &         213,    216,     217,   222,     223,     226,    227/

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

!   Start subroutine:
    sigmat8 = zro
    ics = 10000*l + 1000*ms + 100*mb + 10*ksi + iks
    js = 1
    do js = 1,28
       if (ics == icst(js)) then
!   (js will be <= 19, if no photons]).
          sigmat8 = sDCM%qints (t, js)
          if (js == 10) sigmat8 = absfct*sigmat8
          if (js == 22) then
             sigmat8 = absfct2*sigmat8
             if (t < 0.00224d0) sigmat8 = zro
          endif
          if (js == 20 .or. js == 21 .or. js == 28) then
             if (t < 0.15150d0) sigmat8 = zro
          endif
          if (js >= 23 .and. js <= 27) then
             if (t < 0.321d0) sigmat8 = zro
          endif
          return
       endif
    end do
    nsjs = 1
10  if (ics.ne.nsicst(nsjs)) then
       nsjs = nsjs + 1
       if (nsjs < 21) go to 10
    endif
    kns = nsjs
!  1-4: pi+ + p  or  pi- + n  cross section
    if (kns == 1  .or. kns == 3  .or. kns == 14 .or. kns == 15 .or. &
         & kns == 16 .or. kns == 18 .or. kns == 19) then
       sigmat8 = zro
    elseif (kns == 2) then
       sigmat8 = absfct*sDCM%qints (t, 10)
    elseif (kns == 4) then
!  [117] Total pi+ + p or pi- + n pion production cross section:
       sigmat8 = sDCM%qints (t, 15) + sDCM%qints (t, 16)
    elseif (kns == 5) then
!  [127] Total pi- + p or pi+ + n pion production cross section:
       sigmat8 = sDCM%qints (t, 17) + sDCM%qints (t, 18) + sDCM%qints (t, 19)
!  6-13: pi0-p  or  pi0-n  cross sections
    elseif (kns == 6) then
       sigmat8 = (sDCM%qints (t, 8) + sDCM%qints (t, 5))/two
    elseif (kns == 7) then
       sigmat8 = (sDCM%qints (t, 9) + sDCM%qints (t, 6) - sDCM%qints (t, 7))/two
    elseif (kns == 8) then
       sigmat8 = sDCM%qints (t, 7)
    elseif (kns == 9) then
       sigmat8 = 0.5d0*absfct*sDCM%qints (t, 10)
    elseif (kns == 10) then
       sigmat8 = (sDCM%qints (t, 15) + sDCM%qints (t, 18))/two
    elseif (kns == 11) then
       sigmat8 = (sDCM%qints (t, 16) + sDCM%qints (t, 19))/two
    elseif (kns == 12) then
       sigmat8 = sDCM%qints (t, 17)/two
    elseif (kns == 13) then
!  [137] Total pi0+p or pi0+n pion production cross section:
       sigmat8 = (sDCM%qints (t, 15) + sDCM%qints (t, 16) + sDCM%qints (t, 17) + &
            & sDCM%qints (t, 18) + sDCM%qints (t, 19))/two
!  14-17: p-p  or  n-n  cross sections
    elseif (kns == 17) then
!  [217] Total p+p or n+n pion production cross section:
       sigmat8 = sDCM%qints (t, 11) + sDCM%qints (t, 12)
!  18-21: p-n cross sections
    elseif (kns == 20) then
       sigmat8 = sDCM%qints (t, 13)
    elseif (kns == 21) then
!  [227] Total p+n pion-production cross section:
       sigmat8 = sDCM%qints(t, 13) + two*sDCM%qints(t, 14)
    endif
    return

! ======================================================================
  end function sigmat8


      subroutine pl_fert (jj, ifrt, frt_kg, fertop)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine applies N and P specified by date and
!!    amount in the management file (.mgt)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    SWAT: Erfc

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use mgt_operations_module
      use fertilizer_data_module
      use basin_module
      use organic_mineral_mass_module
      use hru_module, only : ihru, fertn, fertp, fertnh3, fertno3, fertorgn, fertorgp, fertp,  &
        fertsolp

      implicit none

      real, parameter :: rtof=0.5         !none          |weighting factor used to partition the
                                          !              |organic N & P concentration of septic effluent
                                          !              |between the fresh organic and the stable
                                          !              |organic pools
      integer :: j                        !none          |counter
      integer :: l                        !none          |counter
      integer, intent (in) :: jj          !none          |counter
      integer, intent (in) :: ifrt        !              |fertilizer type from fert data base
      integer, intent (in) :: fertop      !              |
      real, intent (in) :: frt_kg         !kg/ha         |amount of fertilizer applied
      real :: xx                          !              |
      real :: gc                          !none          |fraction of ground covered by plant foliage
      real :: gc1                         !              |
      real :: swf                         !cfu           |fraction of manure containing active colony forming units
      real :: frt_t                       !              |

      !!added by zhang
      !!======================
      real :: X1, X8, X10, XXX, YY, ZZ, XZ, YZ, RLN, orgc_f

      j = ihru

      X1 = 0.
      X8 = 0.
      X10 = 0.
      XXX = 0.
      YY = 0.
      ZZ = 0.
      XZ = 0.
      YZ = 0.
      RLN = 0.
      orgc_f = 0.
      !!added by zhang
      !!======================

      !j = jj

      do l = 1, 2
        xx = 0.
        if (l == 1) then
          xx = chemapp_db(fertop)%surf_frac
        else
          xx = 1. - chemapp_db(fertop)%surf_frac
        endif

        soil1(j)%mn(l)%no3 = soil1(j)%mn(l)%no3 + xx * frt_kg *          &
            (1. - fertdb(ifrt)%fnh3n) * fertdb(ifrt)%fminn

        if (bsn_cc%cswat == 0) then
        soil1(j)%tot(l)%n = soil1(j)%tot(l)%n + rtof * xx * frt_kg *   &
                       fertdb(ifrt)%forgn
        soil1(j)%hs(l)%n = soil1(j)%hs(l)%n + (1. - rtof) * xx * &
            frt_kg * fertdb(ifrt)%forgn
        soil1(j)%tot(l)%p = soil1(j)%tot(l)%p + rtof * xx * frt_kg *   &
                       fertdb(ifrt)%forgp
        soil1(j)%hp(l)%p = soil1(j)%hp(l)%p + (1. - rtof)*xx*frt_kg *  &
                       fertdb(ifrt)%forgp
        end if
	  if (bsn_cc%cswat == 1) then
	  soil1(j)%man(l)%c = soil1(j)%man(l)%c + xx * frt_kg *            &
      		fertdb(ifrt)%forgn * 10.
	  soil1(j)%man(l)%n = soil1(j)%man(l)%n + xx * frt_kg *            &
      		fertdb(ifrt)%forgn
	  soil1(j)%man(l)%p = soil1(j)%man(l)%p + xx * frt_kg *            &
      		fertdb(ifrt)%forgp
	  end if

        !!By Zhang for C/N cycling
        !!===========================
	  if (bsn_cc%cswat == 2) then
        soil1(j)%tot(l)%p = soil1(j)%tot(l)%p + rtof * xx *           &
            frt_kg * fertdb(ifrt)%forgp
        soil1(j)%hp(l)%p = soil1(j)%hp(l)%p + (1. - rtof) * xx *  &
            frt_kg * fertdb(ifrt)%forgp

        !!Allocate organic fertilizer to Slow (SWAT_active) N pool;
          soil1(j)%hs(l)%n = soil1(j)%hs(l)%n + (1. - rtof) * xx *  &
                        frt_kg * fertdb(ifrt)%forgn
          soil1(j)%hs(l)%n = soil1(j)%hs(l)%n    !!!same name

          !orgc_f is the fraction of organic carbon in fertilizer
          !for most fertilziers this value is set to 0.
          orgc_f = 0.0
          !X1 is fertlizer applied to layer (kg/ha)
          !xx is fraction of fertilizer applied to layer
          X1 = xx * frt_kg
          !X8: organic carbon applied (kg C/ha)
          X8 = X1 * orgc_f
          !RLN is calculated as a function of C:N ration in fertilizer
          RLN = .175 *(orgc_f)/(fertdb(ifrt)%fminn + fertdb(ifrt)%forgn  &
                                                               + 1.e-5)

          !X10 is the fraction of carbon in fertilizer that is allocated to metabolic litter C pool
          X10 = .85-.018*RLN
          if (X10<0.01) then
            X10 = 0.01
          else
            if (X10 > .7) then
                X10 = .7
            end if
          end if

          !XXX is the amount of organic carbon allocated to metabolic litter C pool
          XXX = X8 * X10
          soil1(j)%meta(l)%c = soil1(j)%meta(l)%c + XXX
          !YY is the amount of fertilizer (including C and N) allocated into metabolic litter SOM pool
          YY = X1 * X10
          soil1(j)%meta(l)%m = soil1(j)%meta(l)%m + YY

          !ZZ is amount of organic N allocated to metabolic litter N pool
          ZZ = X1 *rtof * fertdb(ifrt)%forgn * X10

          soil1(j)%meta(l)%n = soil1(j)%meta(l)%n + ZZ

          !!remaining organic N is llocated to structural litter N pool
          soil1(j)%str(l)%n = soil1(j)%str(l)%n + X1 * fertdb(ifrt)%forgn - ZZ
          !XZ is the amount of organic carbon allocated to structural litter C pool
          XZ = X1 *orgc_f-XXX
          soil1(j)%str(l)%c = soil1(j)%str(l)%c + XZ

          !assuming lignin C fraction of organic carbon to be 0.175; updating lignin amount in strucutral litter pool
          soil1(j)%lig(l)%c = soil1(j)%lig(l)%c + XZ * .175
          !non-lignin part of the structural litter C is also updated;
          soil1(j)%lig(l)%n = soil1(j)%lig(l)%n + XZ * (1.-.175)

          !YZ is the amount of fertilizer (including C and N) allocated into strucutre litter SOM pool
          YZ = X1 - YY
          soil1(j)%str(l)%m = soil1(j)%str(l)%m + YZ
          !assuming lignin fraction of the organic fertilizer allocated into structure litter SOM pool to be 0.175;
          !update lignin weight in structural litter.
          soil1(j)%lig(l)%m = soil1(j)%lig(l)%m + YZ*.175
          soil1(j)%tot(l)%n = soil1(j)%meta(l)%n + soil1(j)%str(l)%n

          !end if

	  end if
        !!By Zhang for C/N cycling
        !!===========================

        soil1(j)%mn(l)%nh4 = soil1(j)%mn(l)%nh4 + xx * frt_kg *          &
            fertdb(ifrt)%fnh3n * fertdb(ifrt)%fminn

        soil1(j)%mp(l)%lab = soil1(j)%mp(l)%lab + xx * frt_kg *          &
            fertdb(ifrt)%fminp

      end do

!! summary calculations
      fertno3 = frt_kg * fertdb(ifrt)%fminn * (1. - fertdb(ifrt)%fnh3n)
      fertnh3 = frt_kg * (fertdb(ifrt)%fminn * fertdb(ifrt)%fnh3n)
      fertorgn = frt_kg * fertdb(ifrt)%forgn
      fertsolp = frt_kg * fertdb(ifrt)%fminp
      fertorgp = frt_kg * fertdb(ifrt)%forgp
      fertn = fertn + frt_kg * (fertdb(ifrt)%fminn +         &
                                                   fertdb(ifrt)%forgn)
      fertp = fertp + frt_kg * (fertdb(ifrt)%fminp +         &
                                                   fertdb(ifrt)%forgp)
      return
      end subroutine pl_fert


!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: hydmod.f90 6649 2016-10-12 12:09:03Z jeuke_ml $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/utils_lgpl/hyd_to_waq_part_lib/packages/hyd_to_waq_part_lib/src/hydmod.f90 $

      module hydmod

      ! module contains everything for the hydrodynamic discription
      ! created June 2004 by Jan van Beek
      !
      ! contains the following derived types:
      !
      !    t_hyd                   ! poperties with respect to a hydrodynamic

      use filmod                   ! module contains everything for the files
      use wstmod                   ! module contains everything for the wastloads discription
      use domain_mod               ! module contains everything for the domain discription
      use dlwqdata_mod
      use io_ugrid
      implicit none

      integer, parameter :: FILE_NAME_SIZE    = 256          ! length all names
      integer, parameter :: NAME_SIZE         =  20          ! size of descriptive names
      integer, parameter :: TEXT_SIZE         =  40          ! descriptive text size
      integer, parameter, private               :: MAX_NUM    =    5      ! allocated per bunch

      ! task types

      integer, parameter          :: HYD_TASK_UNKNOWN  =   0          ! unknown
      integer, parameter          :: HYD_TASK_FULL     =   1          ! full-coupling
      integer, parameter          :: HYD_TASK_DDC      =   2          ! dd-coupling

      ! geometry types

      integer, parameter          :: HYD_GEOM_UNKNOWN  =   0          ! unknown
      integer, parameter          :: HYD_GEOM_CURVI    =   1          ! curvilinear-grid
      integer, parameter          :: HYD_GEOM_UNSTRUC  =   2          ! unstructured

      ! attributes types

      integer, parameter          :: ATR_UNKNOWN       =   0          ! unknown
      integer, parameter          :: ATR_OLD           =   1          ! old type only surf-mid-bot
      integer, parameter          :: ATR_COMPLETE      =   2          ! full attribute description
      integer, parameter          :: ATR_FM            =   3          ! fm attribute description

      ! open boundaries

      type t_openbndlin
         integer                                :: ibnd                   ! boundary number
         integer                                :: ibnd_new               ! renumbered boundary number (0 = inactive)
         real*8                                 :: x1                     ! x1
         real*8                                 :: y1                     ! y1
         real*8                                 :: x2                     ! x2
         real*8                                 :: y2                     ! y2
      end type t_openbndlin

      type t_openbndlin_coll
         type(t_openbndlin), pointer            :: openbndlin_pnts(:)     ! pointer to the openbndlin descriptions
         integer                                :: maxsize                ! maximum size of the current array
         integer                                :: cursize                ! filled up to this size
      end type t_openbndlin_coll

      type t_openbndsect
         character(len=256)                     :: name                   ! boundary section name
         type(t_openbndlin_coll)                :: openbndlin_coll        ! the collection of boundaries
      end type t_openbndsect

      type t_openbndsect_coll
         type(t_openbndsect), pointer           :: openbndsect_pnts(:)    ! pointer to the openbndsect descriptions
         integer                                :: maxsize                ! maximum size of the current array
         integer                                :: cursize                ! filled up to this size
      end type t_openbndsect_coll

      type t_hyd
         type(t_dlwqfile)                       :: file_hyd               ! name of hydrodynamic description file
         integer                                :: task                   !
         integer                                :: geometry               !
         integer                                :: horizontal_aggregation !
         integer                                :: minimum_vdf_used       !
         integer                                :: vertical_diffusion     !
         character(len=TEXT_SIZE)               :: description(3)         !
         character*14                           :: hyd_ref                ! hydrodynamic reference date
         character*14                           :: hyd_start              ! hydrodynamic start date
         character*14                           :: hyd_stop               ! hydrodynamic stop date
         character*14                           :: hyd_step               ! hydrodynamic time step
         character*14                           :: cnv_ref                ! conversion reference date
         character*14                           :: cnv_start              ! conversion start date
         character*14                           :: cnv_stop               ! conversion stop date
         character*14                           :: cnv_step               ! conversion time step
         integer                                :: cnv_step_sec           ! conversion time step in seconds
         real*8                                 :: time_ref               ! hydrodynamic reference date in julian
         integer                                :: mmax                   ! grid cells m direction
         integer                                :: nmax                   ! grid cells n direction
         integer                                :: kmax                   ! number of layers in hydrodynamics
         integer                                :: nolay                  ! number of layers in conversion
         logical                                :: time_in_seconds        ! time in sources file in seconds or not
         type(t_dlwqfile)                       :: file_com               ! hydrodynamic-file
         type(t_dlwqfile)                       :: file_dwq               ! aggregation-file (horizontal)
         type(t_dlwqfile)                       :: file_vag               ! aggregation-file (vertical)
         type(t_dlwqfile)                       :: file_lga               ! grid-indices-file
         type(t_dlwqfile)                       :: file_cco               ! grid-coordinates-file
         type(t_dlwqfile)                       :: file_bnd               ! boundaries-file
         type(t_dlwqfile)                       :: file_geo               ! waqgeom-file
         type(t_dlwqfile)                       :: file_vol               ! volumes-file
         type(t_dlwqfile)                       :: file_are               ! areas-file
         type(t_dlwqfile)                       :: file_flo               ! flows-file
         type(t_dlwqfile)                       :: file_poi               ! pointers-file
         type(t_dlwqfile)                       :: file_len               ! lengths-file
         type(t_dlwqfile)                       :: file_sal               ! salinity-file
         type(t_dlwqfile)                       :: file_tem               ! temperature-file
         type(t_dlwqfile)                       :: file_vdf               ! vert-diffusion-file
         type(t_dlwqfile)                       :: file_srf               ! surfaces-file
         type(t_dlwqfile)                       :: file_hsrf              ! horizontal-surfaces-file
         type(t_dlwqfile)                       :: file_lgt               ! total-grid-file
         type(t_dlwqfile)                       :: file_src               ! discharges-file
         type(t_dlwqfile)                       :: file_chz               ! chezy-coefficients-file
         type(t_dlwqfile)                       :: file_tau               ! shear-stresses-file
         type(t_dlwqfile)                       :: file_wlk               ! walking-discharges-file
         type(t_dlwqfile)                       :: file_atr               ! attributes-file
         type(t_dlwqfile)                       :: file_dps               ! depths-file
         type(t_dlwqfile)                       :: file_ddp               ! ddp-file
         type(t_dlwqfile)                       :: file_rfl               ! river flow file
         logical                                :: sal_present            ! indication if salinity is availeble
         logical                                :: tem_present            ! indication if temperature is availeble
         logical                                :: tau_present            ! indication if tau is availeble
         logical                                :: vdf_present            ! indication if vertical diffusion is availeble
         real                                   :: min_vdf_upper          ! minimum-vert-diffusion-upper-layer
         real                                   :: min_vdf_lower          ! minimum-vert-diffusion-lower-layer
         real                                   :: min_vdf_interface      ! minimum-vert-diffusion-interface-depth
         real                                   :: disp_first             ! constant-dispersion-first-direction
         real                                   :: disp_second            ! constant-dispersion-second-direction
         real                                   :: disp_third             ! constant-dispersion-third-direction
         real, pointer                          :: hyd_layers(:)          ! hydrodynamic-layers
         real, pointer                          :: waq_layers(:)          ! water-quality-layers
         type(t_wasteload_coll)                 :: wasteload_coll         ! the wasteloads
         type(t_dlwqdata)                       :: wasteload_data         ! the data of the wasteloads
         type(t_domain_coll)                    :: domain_coll            ! the domains
         type(t_dd_bound_coll)                  :: dd_bound_coll          ! the dd boundaries
         type(t_openbndsect_coll)               :: openbndsect_coll       ! the (dlflowfm) boundary sections
         integer                                :: noseg                  ! number of segments
         integer                                :: nosegl                 ! number of segments per layer
         integer                                :: nobnd                  ! number of boundaries
         integer                                :: nobndl                 ! number of boundaries per layer
         integer                                :: lnx                    ! number of flow links
         integer                                :: noq                    ! number of exchanges
         integer                                :: noq1                   ! number of exchanges in first direction
         integer                                :: noq2                   ! number of exchanges in second direction
         integer                                :: noq3                   ! number of exchanges in third direction
         integer                                :: noq4                   ! number of exchanges in fourth direction
         real, pointer                          :: volume(:)              ! volume
         real, pointer                          :: area(:)                ! area
         real, pointer                          :: flow(:)                ! flow
         real, pointer                          :: displen(:,:)           ! displen
         real, pointer                          :: surf(:)                ! surf
         real, pointer                          :: depth(:)               ! depth
         real, pointer                          :: sal(:)                 ! sal
         real, pointer                          :: tem(:)                 ! tem
         real, pointer                          :: tau(:)                 ! tau
         real, pointer                          :: vdf(:)                 ! vdf
         integer, pointer                       :: lgrid(:,:)             ! active grid table
         integer, pointer                       :: ipoint(:,:)            ! pointer table
         real, pointer                          :: xdepth(:,:)            ! x coordinates depth points
         real, pointer                          :: ydepth(:,:)            ! y coordinates depth points
         real, pointer                          :: gsqs(:,:)              ! hydro grid cell surface
         integer                                :: atr_type               ! type of attribute information
         integer                                :: no_atr                 ! number of attributes
         integer, pointer                       :: attributes(:)          ! attributes
         real                                   :: min_disp_len           ! minimum-dispersion-length
         logical                                :: l_ascii                ! indication if ascii output is asked

         integer, pointer                       :: idomain(:)             ! idomain
         integer, pointer                       :: iglobal(:)             ! global cell numbering
         integer, pointer                       :: iglobal_bnd(:)         ! global boundary numbering
         integer, pointer                       :: ilocal_link(:)         ! local number in owner domain
         integer, pointer                       :: iglobal_link(:)        ! iglobal_link
         integer                                :: numcontpts             ! numcontpts number of contour nodes
         real*8, pointer                        :: flowelemcontourx(:,:)  ! flowelemcontourx
         real*8, pointer                        :: flowelemcontoury(:,:)  ! flowelemcontoury
         integer                                :: lnx1d                  ! number of 1d pointers
         real*8, pointer                        :: xu(:)                  ! xu
         real*8, pointer                        :: yu(:)                  ! yu

         integer                                :: numk                   ! number of nodes
         real*8, pointer                        :: xk(:)                  ! xu
         real*8, pointer                        :: yk(:)                  ! yu
         real*8, pointer                        :: zk(:)                  ! yu
         integer                                :: numl                   !< number of nodes links
         integer, pointer                       :: kn(:,:)                !< node links
         integer                                :: nv                     !< max nr of nodes describing an element
         integer                                :: nump                   !< number of elements
         integer, pointer                       :: netcellnod(:,:)        !< element nodes
         type(t_crs)                            :: crs                    !< Container for information about coordinate reference system

      end type t_hyd

      type t_hyd_coll
         type(t_hyd), pointer                   :: hyd_pnts(:)            ! pointer to the hyd descriptions
         integer                                :: maxsize                ! maximum size of the current array
         integer                                :: cursize                ! filled up to this size
      end type t_hyd_coll

      interface coll_find
         module procedure openbndsect_coll_find
      end interface

      interface coll_add
         module procedure openbndsect_coll_add
         module procedure openbndlin_coll_add
      end interface

      contains

      ! function to find a section name in a collection, case sensitive at the moment

      function openbndsect_coll_find( openbndsect_coll, name ) result ( iret )

         type(t_openbndsect_coll)               :: openbndsect_coll       ! collection of openbndsects
         character(LEN=*)                       :: name                   ! name of openbndsect to be found
         integer                                :: iret                   ! result index in collection or 0 if not found

         integer                                :: i                      ! loop counter

         iret = 0
         do i = 1 , openbndsect_coll%cursize
            if ( openbndsect_coll%openbndsect_pnts(i)%name .eq. name ) then
               iret = i
               return
            endif
         end do

      end function openbndsect_coll_find

      ! function to add to a collection of openbndsects

      function openbndsect_coll_add( openbndsect_coll , openbndsect ) result ( cursize )

         type(t_openbndsect_coll)               :: openbndsect_coll       ! collection of openbndsects
         type(t_openbndsect)                    :: openbndsect            ! openbndsect to be added
         integer                                :: cursize                ! return value the new current collection size
                                                                          ! and the index of the added openbndsect

         type(t_openbndsect), pointer           :: openbndsect_pnts(:)    ! pointer for the resize operation
         integer                                :: i                      ! loop counter

         if ( openbndsect_coll%cursize .eq. openbndsect_coll%maxsize ) then

            ! resize, allocate new array

            allocate ( openbndsect_pnts ( openbndsect_coll%maxsize + MAX_NUM ) )

            ! copy the openbndsects into the new array

            do i = 1 , openbndsect_coll%maxsize
               openbndsect_pnts(i) = openbndsect_coll%openbndsect_pnts(i)   ! copies the openbndsects
            enddo

            ! deallocate the old array and attach the new array to the collection

            if ( openbndsect_coll%maxsize .ne. 0 ) deallocate ( openbndsect_coll%openbndsect_pnts )
            openbndsect_coll%openbndsect_pnts => openbndsect_pnts
            openbndsect_coll%maxsize = openbndsect_coll%maxsize + MAX_NUM

         endif

         openbndsect_coll%cursize = openbndsect_coll%cursize + 1
         openbndsect_coll%openbndsect_pnts(openbndsect_coll%cursize ) = openbndsect
         cursize = openbndsect_coll%cursize
         return

      end function openbndsect_coll_add

      ! function to add to a collection of openbndlins

      function openbndlin_coll_add( openbndlin_coll , openbndlin ) result ( cursize )

         type(t_openbndlin_coll)                :: openbndlin_coll        ! collection of openbndlins
         type(t_openbndlin)                     :: openbndlin             ! openbndlin to be added
         integer                                :: cursize                ! return value the new current collection size
                                                                          ! and the index of the added openbndlin

         type(t_openbndlin), pointer            :: openbndlin_pnts(:)     ! pointer for the resize operation
         integer                                :: i                      ! loop counter

         if ( openbndlin_coll%cursize .eq. openbndlin_coll%maxsize ) then

            ! resize, allocate new array

            allocate ( openbndlin_pnts ( openbndlin_coll%maxsize + MAX_NUM ) )

            ! copy the openbndlins into the new array

            do i = 1 , openbndlin_coll%maxsize
               openbndlin_pnts(i) = openbndlin_coll%openbndlin_pnts(i)   ! copies the openbndlins
            enddo

            ! deallocate the old array and attach the new array to the collection

            if ( openbndlin_coll%maxsize .ne. 0 ) deallocate ( openbndlin_coll%openbndlin_pnts )
            openbndlin_coll%openbndlin_pnts => openbndlin_pnts
            openbndlin_coll%maxsize = openbndlin_coll%maxsize + MAX_NUM

         endif

         openbndlin_coll%cursize = openbndlin_coll%cursize + 1
         openbndlin_coll%openbndlin_pnts(openbndlin_coll%cursize ) = openbndlin
         cursize = openbndlin_coll%cursize
         return

      end function openbndlin_coll_add

      end module hydmod


!****************************************************************************************
!> Module mod_globalVariables (list of globally shared variables and pointers)
!
! This module contains the list of all globally shared variables. This includes:
! 1) Processor and mesh information (code backbone)
! 2) Reaction lists, defect lists, and cascade lists, both in coarse and fine meshes
! 3) Global reaction rates
! 4) Material input information, in the form of derived types (diffusion and binding energies, etc)
! 5) Universal constants
! 6) Simulation parameters read in from configure.in
! 7) Other miscellaneous variables used for MPI, debugging, or postprocessing
!****************************************************************************************
module mod_globalvariables
    use mod_constants
    use mod_structures
    implicit none

    !*************************************************************
    !>MPI, processor and mesh information
    !************************************************************
    integer :: comm                             !<New communication domain: created by MPI_CART_CREAT
    integer :: dims(3)                          !<Number of processors in x, y, z.
    logical, dimension(3) :: periods=(/.true., .true., .true./)     !<Boundary conditions in x, y, z.  The default is periodic
    integer :: ierr							    !<used for initializing and finalizing MPI
    double precision :: commTimeSum             !<total communication time
    double precision :: allreduceTime           !<total global communiaction time
    double precision :: casCommTime             !<total point-to-point communication time used for cascade implantation
    double precision :: otherCommTime           !<total point-to-point communication time ued for other cases

    !>Processor information
    type(processorData) :: myProc				!<Contains processor information
    double precision :: totalVolume			    !<Volume of single processor (nm^3)
    double precision :: systemVol				!<Volume of all processors (global)

    !>Mesh information
    type(mesh),allocatable :: myMesh(:)					!<Contains (local) mesh information
    type(ghostMesh),allocatable ::  myGhost(:,:)	    !<Ghost elements (direction, element #)
    integer numCells						            !<Number of cells in local mesh
    integer numTotal                                    !<Total meshes in the sysytem
    double precision meshLength                         !<Length of a coarse mesh
    integer numx,numy,numz                              !<Number of global meshes in x-direction, y-direction, z-direction
    integer numxLocal,numyLocal,numzLocal               !<Number of local meshes in x-direction, y-direction, z-direction

    !reaction and defect lists
    type(reaction),pointer :: reactionList(:)			!<List of reactions in local (coarse) mesh
    type(defect),pointer :: defectList(:)			    !<List of defects in local (coarse) mesh
    double precision,allocatable :: totalRateVol(:)	    !<Total reaction rate in each volume element
    double precision totalRate						    !<Total reaction rate in this processor
    double precision maxRate						    !<Max reaction rate in all processors

    !>Cascade list
    type(cascadeEvent),pointer :: cascadeList			!<List of cascades (read from file) that can be implanted
    type(cascade),pointer :: ActiveCascades				!<List of fine meshes that are active due to recent cascade implantation. Contains defect lists and reaction lists)
    double precision :: PKAtemperature                  !<Temperature of this cascade collision (K)
    double precision :: PKAenergy                       !<Energy of this PKA (eV)
    double precision :: numDisplacedAtoms		        !<number of atoms displaced per cascade, read from cascade file
    integer :: numCascades							    !<number of cascades in the cascade input file
    integer :: numCellsCascade							!<number of volume elements within a cascade (fine) mesh
    integer :: numxCascade,numyCascade,numzCascade	    !<number of elements in cascade x-direction, y-direction, z-direction
    integer,allocatable :: cascadeConnectivity(:,:) 	!<connectivity matrix for cascade meshes (same for all fine meshes)
    double precision :: fineLength						!<length of a cascade volume element (nm)
    double precision :: cascadeElementVol				!<volume of a cascade element (nm^3)

    !*************************************************************
    !>Defect attributes read in from input file
    !************************************************************
    integer :: numSingleForm                !<Number of single defect formation energy in input file
    integer :: numSingleDiff	            !<Number of single defect diffusion rates in input file
    integer :: numFuncDiff		            !<Number of functional forms for diffusion rates in input files
    integer :: numSingleBind                !<Number of single defect binding energies in input file
    integer :: numFuncBind		            !<Number of functional forms for binding energies in input files
    type(formationSingle),allocatable :: FormSingle(:)                  !<Parameters for formation of single defects--(numSingleForm)
    type(diffusionSingle),allocatable :: DiffSingle(:)			        !<Parameters for diffusion of single defects--(numSingleDiff)
    type(diffusionFunction), allocatable :: DiffFunc(:)			        !<Parameters for functional forms of diffusion rates for defects--(numFuncDiff)
    type(bindingSingle), allocatable :: BindSingle(:)				    !<Parameters for binding of single defects--(numSingleBind)
    type(bindingFunction), allocatable :: BindFunc(:)				    !<Parameters for functional forms of binding energies for defects--(numFuncBind)

    integer :: numDissocReac	            !<Number of dissociation reactions in input file
    integer :: numDiffReac		            !<Number of diffusion reactions in input file
    integer :: numSinkReac		            !<Number of sink reactions in input file
    integer :: numImpurityReac	            !<Number of impurity reactions in input file
    integer :: numClusterReac	            !<Number of clustering reactions in input file
    integer :: numImplantReac	            !<Number of implantation reactions in input file (cascade, Frenkel pair currently implemented)
    type(reactionParameters), allocatable :: DissocReactions(:)         !<List of allowed dissociation reactions (and ref. to functional form of reaction rate)--(numDissocReac)
    type(reactionParameters), allocatable :: DiffReactions(:)		    !<List of allowed diffusion reactions (and ref. to functional form of reaction rate)--(numDiffReac)
    type(reactionParameters), allocatable :: SinkReactions(:)		    !<List of allowed sink reactions (and ref. to functional form of reaction rate)--(numSinkReac)
    type(reactionParameters), allocatable :: ImpurityReactions(:)	    !<List of allowed impurity reactions (and ref. to functional form of reaction rate)--(numImpurityReac)
    type(reactionParameters), allocatable :: ClusterReactions(:)	    !<List of allowed clustering reactions (and ref. to functional form of reaction rate)--(numClusterReac)
    type(reactionParameters), allocatable :: ImplantReactions(:)	    !<List of allowed implantation reactions (and ref. to functional form of reaction rate)--(numImplantReac)

    !*************************************************************
    !>Simulation parameters read in from configure.in
    !************************************************************
    !Toggles
    character(len=20) implantType			!<(Frenkel pairs or cascades), used to determine the type of damage in the simulation
    character(len=20) implantScheme			!<(MonteCarlo or explicit), used to determine if cascades are implanted through Monte Carlo algorithm or explicitly
    character(len=20) meshingType			!<(adaptive or nonAdaptive), used to determine whether we are simulating cascade implantation with adaptive meshing
    character(len=20) implantDist			!<(Uniform or NonUniform), used to determine if defects are implanted uniformly or if DPA rate / He implant rate are given for each volume element
    character(len=20) grainBoundaryToggle	!<Used to determine whether or not we are using grain boundaries to remove defects from simulation
    character(len=20) pointDefectToggle		!<Toggles whether or not we allow HeSIA clusters to form ('yes' or 'no')
    character(len=20) polycrystal			!<(yes or no), used to identify whether or not we have multiple grains in our crystal
    !used for test2
    character(len=20) test3                 !<If test3 = 'yes', the simulation becomes a subsequent evolution of a cascade
    integer :: oneCascadeGCell              !<oneCascadeGCell = global cell ID of the mesh to be implanted a cascade
    !<PKA spectrum
    character(len=20) :: PKAspectrum                    !<('yes' or 'no') Whether to use the PKA spectrum
    integer :: numCascadeFiles                          !<cascadeFile: materials_temperature_PKAenergy_*.txt
    type(cascadeFileList), pointer :: cascadeLists(:)   !<List of cascades (read from file) that can be implanted--cascadeLists(numCascadeFiles)
    type(cpdf_t) :: EPKAlist                            !<list of PKA spectrum (cpdf and PKA energies)

    !>Simulation parameters
    double precision :: tempStore		    !<Temperature read in (K) - used when temp. changes several times during a simulation
    double precision :: CuContent           !<The initial content of Cu in iron
    integer :: numVac                       !<The number of vacancies put in
    integer :: numInt                       !<The number of interstitials put in
    double precision :: dpaRate				!<DPA rate in dpa/s
    double precision :: totalDPA			!<total DPA in simulation
    double precision :: firr                !firr = Vconcent / initialCeqv. Radiation enhanced factor
    double precision :: atomSize			!<atomic volume (nm^3)
    double precision :: lattice             !<recombination radius (nm)
    double precision :: burgers				!<magnitude of burgers vector, equal to lattice constant
    double precision :: reactionRadius      !<recombination radius (nm)
    double precision :: agingTime           !<Thermal aging time (s)
    double precision :: grainSize
    double precision :: dislocationDensity	!<density of dislocations (sinks for point defects)
    double precision :: impurityDensity		!<denstiy of impurity atoms (traps for SIA loops)
    double precision :: cascadeVolume		!<Volume of cascade (used for cascade mixing probability)
    double precision :: cascadeReactionLimit!<Total reaction rate in a cascade cell to consider it annealed and release cascade back to coarse mesh (s^-1)
    integer :: max3DInt			            !<largest SIA size that can diffuse in 3D as spherical cluster
    integer :: numGrains			        !<Number of grains inside polycrystal (default 1)
    integer :: numSims				        !<Number of times to repeat simulation
    !*********************
    !annealing information
    double precision :: annealTime			!<Amount of time for anneal (s)
    double precision :: annealTemp			!<Temperature of anneal stage (K)
    double precision :: annealTempInc		!<Temperature increment at each annealing step (additive or multipliciative)
    integer	:: annealSteps			        !<Number of annealing steps
    character(len=20) :: annealType		    !<('mult' or 'add') toggles additive or multiplicative anneal steps
    logical :: annealIdentify			    !<(.TRUE. if in annealing phase, .FALSE. otherwise) used to determine how to reset reaction rates (should we include implantation or not)
    integer :: annealIter                   !<Current number of time steps
    !*********************
    !Output  parameters
    character(len=20) :: totdatToggle		!<(yes or no), used to toggle whether we output the totdat.out data file
    character(len=20) :: defectToggle		!<(yes or no), used to toggle whether we output the totdat.out data file
    character(len=20) :: stadatToggle		!<(yes or no), used to toggle whether we output the stadat.out data file
    character(len=20) :: xyzdatToggle		!<(yes or no), used to toggle whether we output the xyzdat.out data file
    integer :: minSCluster                  !<Only n>minSCluster SnVm and Sn clusters are counted
    integer :: minVoid                      !<Only n>minVoid Vn clusters are counted
    integer :: minLoop                      !<Only n>minLoop SIAn clusters are counted
    integer :: minSV                        !<Only (n+m)>minCuV SnVm clusters are counted

    !*************************************************************
    !<Simulation parameters, to be computed during simulation
    !*************************************************************
    !>Constants used for clustering rates
    double precision :: omega				!<Geometric constant for 3D spherical clustering (see Dunn et al. JNM 2013)
    double precision :: omega2D				!<Geometric constant for clustering with dislocation loops (see Dunn et al. JNM 2013)
    double precision :: omega1D				!<Geometric constant for clustering with dislocation loops (see Dunn et al. JNM 2013)
    double precision :: omegastar			!<Geometric constant for 3D spherical clustering (see Dunn et al. JNM 2013)
    double precision :: omegastar1D			!<Geometric constant for clustering with dislocation loops (see Dunn et al. JNM 2013)
    double precision :: omegacircle1D		!<Geometric constant for clustering with dislocation loops (see Dunn et al. JNM 2013)

    !>Simulation parameters, to be computed during simulation
    double precision :: totalTime           !<Total time
    double precision :: elapsedTime         !<Elapsed time
    integer(kind=8) :: step                         !<Current number of time steps
    double precision :: temperature			!<Temperature (K)
    double precision :: DPA					!<DPA tracker (not a parameter)
    double precision :: rateTau(2)          !<Used for collective communication
    double precision :: numImpAnn(3)        !<1: num of Frenkel pairs or cascades (local), 2:number of annihilation reactions carried out (local), 3: total of displaced atoms (local)
    double precision :: totalImpAnn(3)      !<1: num of Frenkel pairs or cascades (global), 2:number of annihilation reactions carried out (global), 3: total of displaced atoms (global)
    !<Cu solubility CeqCu(T) = exp(DelatS/kB)*exp(-Omega/(kB*T))  Reference: (F. Christien and A. Barbu, 2004)
    double precision :: ceqV                !Thermal equilibrium concentration of vacancy
    double precision :: ceqI                !Thermal equilibrium concentration of SIA
    double precision :: concV               !Vacancy concentration
    double precision :: concI               !SIA concentration
    integer :: numCuCell                    !Initial number of Cu atoms in one mesh
    integer :: initialNumV                  !Initial number of vacancies in the whole system
    integer :: initialNumI                  !Initial number of self-interstitial atoms in the whole system
    integer, allocatable :: listVI(:,:)     !List the globalID of the mesh where initial vacancies and self-interstitial atoms are located.

    !>counters for sink efficiency
    integer :: numTrapV			            !<Postprocessing: number of vacancies trapped on grain boundary
    integer :: numTrapSIA			        !<Postprocessing: number of SIAs trapped on grain boundary
    integer :: numEmitV			            !<Postprocessing: number of vacancies emitted from grain boundary
    integer :: numEmitSIA			        !<Postprocessing: number of SIAs emitted from grain boundary

contains

end module


      SUBROUTINE PHO_EVEINI(Imode,P1,P2,Ip1,Ip2)
C********************************************************************
C
C     prepare /POEVT1/ for new event
C
C     first subroutine called for each event
C
C     input:   P1(4)  particle 1
C              P2(4)  particle 2
C              IMODE  0    general initialization
C                     1    initialization of particles and kinematics
C                     2    initialization after internal rejection
C
C     output:  IP1,IP2  index of interacting particles
C
C********************************************************************
      IMPLICIT NONE
      DOUBLE PRECISION DEPS , EPS , onem , P1 , P2
      INTEGER i , im , Imode , ip , Ip1 , Ip2 , ipcomb , ipos , itmp
      SAVE

      DIMENSION P1(4) , P2(4)

      PARAMETER (EPS=1.D-5,DEPS=1.D-15)

C  input/output channels
      INCLUDE 'inc/poinou'
C  event debugging information
      INCLUDE 'inc/podebg'
C  model switches and parameters
      INCLUDE 'inc/pomdls'
C  general process information
      INCLUDE 'inc/poprcs'
C  gamma-lepton or gamma-hadron vertex information
      INCLUDE 'inc/pofsrc'
C  global event kinematics and particle IDs
      INCLUDE 'inc/pogcms'
C**anfe COMMON not needed here
C  energy-interpolation table
C       include 'inc/potabl'
C  cross sections
      INCLUDE 'inc/pocsec'
C  color string configurations including collapsed strings and hadrons
      INCLUDE 'inc/postrg'
C  standard particle data interface
      INCLUDE 'inc/poevt1'
C  extension to standard particle data interface (PHOJET specific)
      INCLUDE 'inc/poevt2'

C  table of particle indices for recursive PHOJET calls
      INCLUDE 'inc/porecu'
C  event weights and generated cross section
      INCLUDE 'inc/powght'

      DIMENSION im(2)

C  reset debug variables
      KSPom = 0
      KHPom = 0
      KSReg = 0
      KHDir = 0
      KSTrg = 0
      KHTrg = 0
      KSLoo = 0
      KHLoo = 0
      KSDpo = 0
      KSOft = 0
      KHArd = 0
C
      IDNodf = 0
      IDIfr1 = 0
      IDIfr2 = 0
      IDDpom = 0
      ISTr = 0
      IPOix1 = 0
      IF ( ISWmdl(14).GT.0 ) IPOix1 = 1
      IPOix2 = 0
      IPOix3 = 0
C  reset /POEVT1/ and /POEVT2/
      CALL PHO_REGPAR(0,0,0,0,0,0.D0,0.D0,0.D0,0.D0,0,0,0,0,ipos,0)
      CALL PHO_SELCOL(0,0,0,0,0,0,0)
      DO i = 0 , 10
         IPOwgc(i) = 0
      END DO

C  initialization of particle kinematics
C  Initialize elastic scattering with initial kinematics
      IF ( ISWmdl(13).EQ.0 ) THEN
         ipcomb = 0
         IF ( ABS(IFPap(1)).EQ.2212 .AND. IFPap(1).EQ.IFPap(2) ) THEN
            ipcomb = 1
         ELSE IF ( ABS(IFPap(1)).EQ.2212 .AND. IFPap(1).EQ.-IFPap(2) )
     &             THEN
            ipcomb = 2
         ELSE
            IF ( LPRi.GT.4 ) WRITE (LO,*)
     &            "PHO_EVEINI: Unsupported particle" ,
     &           "combination for JLL elastic scattering model."
            CALL PHO_ABORT
         END IF
C* FLUKA has a separate version of this model.
C         CALL JLL_SET(ECM**2, IPCOMB, 1)
      END IF
C  lepton-photon/hadron-photon vertex and initial particles
      im(1) = 0
      im(2) = 0
      IF ( (IPAmdl(11).GT.0) .AND. (IDPsrc(1).NE.0) ) THEN
         CALL PHO_REGPAR(1,IDPsrc(1),IDBsrc(1),0,0,PINi(1,1),PINi(2,1),
     &                   PINi(3,1),PINi(4,1),0,0,0,0,im(1),1)
      ELSE
         CALL PHO_REGPAR(1,IFPap(1),IFPab(1),im(1),0,P1(1),P1(2),P1(3),
     &                   P1(4),0,0,0,0,Ip1,1)
      END IF
      IF ( (IPAmdl(12).GT.0) .AND. (IDPsrc(2).NE.0) ) THEN
         CALL PHO_REGPAR(1,IDPsrc(2),IDBsrc(2),0,0,PINi(1,2),PINi(2,2),
     &                   PINi(3,2),PINi(4,2),0,0,0,0,im(2),1)
      ELSE
         CALL PHO_REGPAR(1,IFPap(2),IFPab(2),im(2),0,P2(1),P2(2),P2(3),
     &                   P2(4),0,0,0,0,Ip2,1)
      END IF
      IF ( (IPAmdl(11).GT.0) .AND. (IDPsrc(1).NE.0) ) THEN
         CALL PHO_REGPAR(1,IDPsrc(1),IDBsrc(1),im(1),0,PFIn(1,1),
     &                   PFIn(2,1),PFIn(3,1),PFIn(4,1),0,10,0,0,ipos,1)
         CALL PHO_REGPAR(1,IFPap(1),IFPab(1),im(1),0,P1(1),P1(2),P1(3),
     &                   P1(4),0,0,0,0,Ip1,1)
      END IF
      IF ( (IPAmdl(12).GT.0) .AND. (IDPsrc(2).NE.0) ) THEN
         CALL PHO_REGPAR(1,IDPsrc(2),IDBsrc(2),im(2),0,PFIn(1,2),
     &                   PFIn(2,2),PFIn(3,2),PFIn(4,2),0,10,0,0,ipos,1)
         CALL PHO_REGPAR(1,IFPap(2),IFPab(2),im(2),0,P2(1),P2(2),P2(3),
     &                   P2(4),0,0,0,0,Ip2,1)
      END IF
      NEVhep = KACcep

      IF ( Imode.LE.1 ) THEN
C  CMS energy
         ECM = SQRT((P1(4)+P2(4))**2-(P1(1)+P2(1))**2-(P1(2)+P2(2))
     &         **2-(P1(3)+P2(3))**2)
C       CALL PHO_PECMS(1,PMASS(1),PMASS(2),ECM,PCM,EE)
         PMAss(1) = PHEp(5,Ip1)
         PVIrt(1) = 0.D0
         IF ( IFPap(1).EQ.22 ) PVIrt(1) = PMAss(1)**2
         PMAss(2) = PHEp(5,Ip2)
         PVIrt(2) = 0.D0
         IF ( IFPap(2).EQ.22 ) PVIrt(2) = PMAss(2)**2
      END IF

C  cross section calculations

      IF ( Imode.NE.1 ) THEN
         ip = 1
         CALL PHO_CSINT(ip,IFPap(1),IFPap(2),IGHel(1),IGHel(2),ECM,
     &                  PVIrt(1),PVIrt(2))
      END IF

      IF ( Imode.LE.0 ) THEN
C  effective cross section
         SIGgen(3) = 0.D0
         IF ( ISWmdl(2).GE.1 ) THEN
            IF ( IPRon(1,1).EQ.1 ) SIGgen(3) = SIGtot - SIGela -
     &           SIGvm(0,0) - SIGcdf(0) - SIGlsd(1) - SIGhsd(1)
     &           - SIGlsd(2) - SIGhsd(2) - SIGldd - SIGhdd - SIGdir
            IF ( IPRon(2,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGela
            IF ( IPRon(3,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGvm(0,0)
            IF ( IPRon(4,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGcdf(0)
            IF ( IPRon(5,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGlsd(1)
     &           + SIGhsd(1)
            IF ( IPRon(6,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGlsd(2)
     &           + SIGhsd(2)
            IF ( IPRon(7,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGldd +
     &           SIGhdd
            IF ( IPRon(8,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGdir
C  simulate only hard scatterings
         ELSE
            IF ( IPRon(1,1).EQ.1 ) SIGgen(3) = SIGhar
            IF ( IPRon(8,1).EQ.1 ) SIGgen(3) = SIGgen(3) + SIGdir
         END IF

      END IF

C  reset of mother/daughter relations only (IMODE = 2)

C  debug output
      IF ( IDEb(63).GE.15 ) THEN
         IF ( LPRi.GT.4 ) WRITE (LO,'(/1X,2A,I12,I3)') 'PHO_EVEINI: ' ,
     &        '/POEVT1/ initialized (event/mode)' , KEVent , Imode
         IF ( Imode.LE.0 ) THEN
            IF ( LPRi.GT.4 ) WRITE (LO,'(1X,2A,/,5X,1P,6E12.4)')
     &            'PHO_EVEINI: ' ,
     &        'current suppression factors total-1/2 hard-1/2 diff-1/2:'
     &        , FSUp , FSUh , FSUd
            onem = -1.D0
            itmp = IDEb(57)
            IDEb(57) = MAX(5,itmp)
            CALL PHO_XSECT(1,0,onem)
            IDEb(57) = itmp
         END IF
         CALL PHO_PREVNT(0)
      END IF

      END SUBROUTINE


      SUBROUTINE DIAG(ECONV,ACFG,CFGTOL,LAST,icycle,eigst_weight,
     :                tmp,cf_tot)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
*
      PARAMETER (NWD=70,NOD=220,NOFFD=800)
      parameter(MEIG=20,MTERM=20)
      INCLUDE 'mpif.h'
      parameter (MAXPROC=100)
      common /MPI/ myid, nprocs, ierr, istat(MPI_STATUS_SIZE)
      common /PVM/ istart,ifinish

*
      CHARACTER EL*3,ATOM*6,TERM*6,config*64, couple*80
      INTEGER       IN,OUT,PRI,OUC,OUF,OUH,OUD
      COMMON/INOUT/ IN,OUT,PRI,IUC,IUF,iud,OUC,OUF,OUD,OUH,ISCW
      COMMON/LABEL/ EL(NWD),ATOM,TERM
      LOGICAL       FAIL,OMIT,EZERO,REL,ALL,TRACE,VARIED
      COMMON/TEST/  FAIL,OMIT,EZERO,REL,ALL,TRACE
      COMMON/WAVE/EC,ED,AZD,PDE(NOD),IJE(noffd),EIJ(noffd),IPR
      COMMON/PARAM/  H,H1,H3,CH,EH,RHO,Z,TOL,NO,ND,NWF,MASS,
     :                NCFG,IB,IC,ID,
     :                D0,D1,D2,D3,D4,D5,D6,D8,D10,D12,D16,D30,FINE,
     :                NSCF,NCLOSD,RMASS
      COMMON/RADIAL/R(NOD),RR(NOD),R2(NOD),YK(NOD),YR(NOD),X(NOD)
      POINTER (QWT,WT(1)),(QWP,WP(1)),  (IQWPTR,W(1))
      COMMON /CFGS/ETOTAL,QWT,QWP,IQWPTR
*
      POINTER (IQP,P(NOD,1)),(IQN,N(1)),(IQL,L(1)),(IQAZ,AZ(1)),
     :  (IQMAX,MAX(1)),(QVARD,VARIED(1)),(QSUM,SUM(1)),(QS,S(1)),
     :  (QDPM,DPM(1)),(QACC,ACC(1)),(QMETH,METH(1)),(QIEPTR,IEPTR(1))
      COMMON/NEL/IQP,IQN,IQL,IQAZ,IQMAX,QVARD,QSUM,QS,QDPM,QACC,
     :             QMETH,QIEPTR
*
      POINTER (pkval,kval(1)),(pvalue,value(1)),(pih,ih(1)),(pjh,jh(1)),
     :  (pcoeff,coeff(1)),(pnijptr,nijptr(1)),(pinptr,inptr(1))
      COMMON/STATE/INTPTR(6),IDIM,PKVAL,PVALUE,NZE,PIH,PJH,
     :             NCODIM,PCOEFF,PNIJPTR,PINPTR

      POINTER (plused,lused(1))
      COMMON/USED/plused
      LOGICAL lused

      logical                   ::clst_disk, clst_memory
      common/use_disk/clst_disk, clst_memory
      double precision, allocatable, dimension(:,:) :: isom_shift

      POINTER (pico,ico(1))
      COMMON/ICOFF/pico

      POINTER (qjptr,jptr(1))
      COMMON/COLS/qjptr

      integer idispl(2), icount(2)

      POINTER (qhmx,hmx(1)),(qtm,tm(1)),(qtp,tp(1)),
     :        (qdiag,hii(1)),(qiwork,iwork(1))
      common/spd/qhmx,qtm,qtp,qdiag,qiwork

      dimension tmp(*)
      integer cf_tot(nblock)

      double precision eigst_weight(meig,mterm)
      logical   ldused
      character*64  string
      logical leigen(meig,mterm), lguess, leig_out
      integer nume(mterm),iws(mterm),iiws(mterm),
     :        nze_bl(mterm), ncfg_bl(mterm), niv_bl(mterm)
      character term_bl(mterm)*3
      pointer   (qeigvec,eigvec(1)),(pen,en(1))
      common/st/leigen,nblock,nume,iws,iiws,ncfg_bl,nze_bl,
     :          term_bl, qeigvec, pen, lguess
*
      INTEGER iselec(20)
      LOGICAL ECONV,LAST,iguess,iupper,hiend,lfirst
      DATA iguess,iupper,lfirst/.false.,.false.,.true./
      DATA crite,critc,critr,trhold,ortho/
     :       1.d-14,1.d-8,1.d-8,1.d0,1.d0/

*     .. this is a matrix in memory version
      idisk = 0
      leig_out = .false.
******
      nze = maxval(nze_bl(1:nblock))
!!!      lim = maxval(iiws(1:nblock))
      lim = 1000;
      iiwsz = 6*lim + maxval(nume(1:nblock))
      iworksz = maxval(iws(1:nblock))
Ctc 19/03/2008 : crash of large calculations on several nodes of hydra@ulb
Ctc   print *, 'IWSZ, iworksz = ', iiwsz, iworksz
      WRITE (80+myid,*) 'IWSZ, iworksz = ', iiwsz, iworksz
Ctc
*  .. for block calculation, we use block information ??????

*     In generating the matrix, we need to read in the data,

      rewind 39
      etl = 0
      sum_energy = 0

*<<<<<<<<<<<<<<<<< for all blocks >>>>>>>>>>>>>>>
*
*    .. we have global arrays from yint.lst
*      ih, ico -- these increment according to the number of nze
*      jptr    -- this increments by ncfg
*    .. arrays from c.lst are buffered with dimensions ncodim (also lsdim)
*
*     nz is a pointer to the end of the previous block of ih, ico
*     nj is a pointer to the end of the previous block of jptr
*     ievstart is the beginning of the current block of eigenvectors
*     ies is start of current set of eigenvalue
*<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

      nz = 0
      nj = 0
      ijp = 1
      ievstart = 1
      ies = 1
      ibe = 0;
      ncoef = 0;
      do iblock = 1,nblock
      istart =  -1;
*       .. set parameters to current block
        ncfg = ncfg_bl(iblock)
        nze = nze_bl(iblock)
        lim = iiws(iblock)
	iworksz = iws(iblock)
        iiwsz = 6*lim + nume(iblock)
        call dfill(nze,0.0d0,hmx,1)
        nijcurr = 1
        max_col = 1; jjh = 1

        if (clst_memory) then
           call coeff_memory(cf_tot(iblock),ncoef,ico,nz,hmx,coeff,
     :                    value,inptr,jptr,jjh,nijcurr)

        else
           call coeff_disk(ncoef,ico,nz,hmx,coeff,
     :                  value,inptr,jptr,jjh,nijcurr,ncodim)
        end if

*     .. compute diagonals

        if (myid.eq.0) then
           shift = hmx(1)
        end if

        call MPI_BCAST(shift,1,MPI_DOUBLE_PRECISION,0,
     :                  MPI_COMM_WORLD,ierr)

        call DINIT(NCFG,0.d0,hii,1)

*        ..all the nodes should shift their first hmx(1)
*        ..interleaved

         hii(myid+1)=hmx(1)-shift
         hmx(1)=hii(myid+1)
         m_col=1
         do irow=myid+1+nprocs,NCFG,nprocs
            m_col=m_col+1
            hii(irow)=hmx(jptr(m_col-1+nj)+1) - shift
            hmx(jptr(m_col-1+nj)+1)= hii(irow)
         end do

       call gdsummpi(hii,NCFG,tm)
       ! call mpi_allr_dp(hii,ncfg)

*
****** COMPUTE THE EIGENVALUES AND EIGENVECTORS
*

      hiend = .false.
      ilow = -1
      ihigh = -1

      ie = 1
      do i = 1,meig
         if (leigen(i,iblock)) then
           iselec(ie) = i
           ie = ie + 1
         end if
      end do
      iselec(ie) = -1

      if (.not. lguess) then
        niv = 0
      else
        niv = niv_bl(iblock)
        call dcopy(ncfg*niv,eigvec(ievstart),1,wt(1),1)
      end if
      mblock = ie-1
*      if (myid == 0) then
*      print *, 'hmx:'
*      print '(3F20.16)', (hmx(i),i=1,jptr(ncfg))
*      end if
*      print *, 'ih:'
*      print '(4I6)', (ih(i+nz),i=1,jptr(ncfg))
*      print *, 'jptr:', (jptr(i+nj),i=1,ncfg)
*      print *, 'iupper,nze,ncfg,lim:',iupper,nze,ncfg,lim
*      if (myid == 0 ) then
*      print *, 'diag :'
*      print '(3F20.16)',(hii(i),i=1,ncfg)
*      end if
*     print *, 'ilow,ihigh,iselec(1),iselec(2),iselec(3)',
*    :          ilow,ihigh,iselec(1),iselec(2),iselec(3)
ctc avoid ierr=2048 in CI
ctc      maxiter = max0(30*nume(iblock),100)
      NIT=NWF-IB+1
      IF (NIT==0) THEN
        write(0,*) 'CI calculation, maxiter increased'
        maxiter = max0(30*nume(iblock),400)
      ELSE
        maxiter = max0(30*nume(iblock),100)
      END IF
ctc
*     print *, 'niv,crite,critc,critr,trhold,ortho,maxiter',
*    :          niv,crite,critc,critr,trhodl,ortho,maxiter
*     print *,  'ncfg,lim', ncfg,lim
*     write(0,*) ' Calling eigen: worksize=',iworksz,n,nze

      CALL dvdson(hmx,ih(nz+1),jptr(nj+1),iupper,nze,tm,tp,
     :        Ncfg,lim,hii,ilow,ihigh,iselec,niv,mblock,
     :        crite,critc,critr,ortho,maxiter,
     :        wt,iworksz,iwork,iiwsz,hiend,nloops,nmv,ierr)

****** deallocate when not needed

      if (ierr .ne. 0) then
         if (myid == 0) then
            write(0,*) ' Dvdson returned ierr=',ierr
            write(0,*) ' ... continuing'
         end if
      end if

      if (hiend) then
Ctc 19/03/2008 : crash of large calculations on several nodes of hydra@ulb
Ctc      print *, 'exit: dvdson returned hiend = true; enter 0 to stop'
         WRITE (80+myid,*)
     :             'exit: dvdson returned hiend = true; enter 0 to stop'
Ctc
         read *, i
         if (i.eq.0) stop
      end if

*      print *, (wt(i), i=1,ncfg)

      if (lguess .eqv. .false.) lguess = .true.
      do icc = 1, nume(iblock)
        if (leigen(icc,iblock)) then
           ioffw = ncfg*(icc-1)
           ioffe = icc
           j = idamax(ncfg,wt(ioffw+1),1)
           if (wt(j+ioffw) .lt. 0) then
             wt(ioffw+1:ioffw+ncfg) = -wt(ioffw+1:ioffw+ncfg)
           end if
           etl =  wt(ncfg*nume(iblock)+ioffe) + ec + shift
	   wt(ncfg*nume(iblock)+ioffe) = etl
           sum_energy = sum_energy +etl*eigst_weight(icc,iblock)
         end if
      end do

*        .. save eigenvectors and eigenvalues
         call dcopy(ncfg*nume(iblock),wt(1),1,eigvec(ievstart),1)
         call dcopy(nume(iblock), wt(ncfg*nume(iblock)+1),1,en(ies),1)
*        .. print Energies and some component of eigenvectors
*	 ioffw = ncfg*nume(iblock)
	 do ie = 1,nume(iblock)
         ioffw = ncfg*nume(iblock)
	   if( leigen(ie,iblock)) then
            if (myid == 0) then
            write (out,'(/A,F15.8,3X,A,I3,2(1PD11.3))')
     :      '         ETOTAL=',wt(ioffw+ie),
     :      'Loops,DeltaE,Res.: ', nloops,
     :      wt(ioffw+nume(iblock)+ie),
     :      wt(ioffw+2*nume(iblock)+ie)
            end if
	    ioffw = ncfg*(ie-1)
            if (myid == 0 ) then
	    write(out,'(4(4X,I3,F11.7))') (i,wt(ioffw+i),i=1,min(8,ncfg))
            end if
	   end if
	 end do
*        .. we now have nume starting vectors for the next iteration
         niv_bl(iblock) = nume(iblock)

*        .. update the terminating/starting locations
         ievstart = ievstart + ncfg*nume(iblock)
         ies = ies +nume(iblock)
         nj = nj + m_col   !nijcurr
	 nz = nz + nijcurr !jptr(nj)
      end do

      call MPI_BARRIER(MPI_COMM_WORLD,ierr)

*<<<<<<<<<<<< end blocks >>>>>>>>>>>>

      if (last) then
        if (qhmx.ne.0) call dalloc(qhmx,nze)
        if (qtm.ne.0) call dalloc(qtm,ncfg)
        if (qtp.ne.0) call dalloc(qtp,ncfg)
        if (qdiag.ne.0) call dalloc(qdiag,ncfg)
        if (qiwork.ne.0) call dalloc(qiwork,iiwsz)
      end if

      allocate(isom_shift(MEIG,MTERM));
      isom_shift(1:MEIG,1:MTERM) = 0.0D0;
      lguess = .true.
      deltae = sum_energy - etotal
      if (abs(deltae) .lt. cfgtol) econv = .TRUE.
      etotal = sum_energy
      if (myid.eq.0) then
        write(out, '(/9x,A,F15.8)') 'Sum of ETOTAL :  ',etotal
        write(iscw,*)' DeltaE =', deltae, 'Sum_Energy = ' , sum_energy
      end if
      ievstart = 1
      rewind(39)
      ijp = 1
      nz  = 1
      ibe = 0;
      ncoef = 0;
      do iblock = 1,nblock
         ncfg = ncfg_bl(iblock)
         if(clst_memory) then
           CALL UPDATC_memory(iblock,eigvec(ievstart),ncfg,nume(iblock),
     :     jptr(ijp),ih(nz), ico(nz), eigst_weight,tmp,max_col,nijcurr,
     :     cf_tot,last,isom_shift)
         else
           CALL UPDATC_disk(iblock,eigvec(ievstart),ncfg,nume(iblock),
     :     jptr(ijp),ih(nz), ico(nz), eigst_weight,tmp,max_col,nijcurr,
     :     last,isom_shift)
         end if
         ievstart = ievstart + ncfg*nume(iblock)
         ijp = ijp + max_col
         nz = nz + nijcurr
      end do
*
      if (myid.eq.0) then
        DO I=1,nwf
        IF(SUM(I).EQ.0.0)write(iscw,*)'DIAG: SUM=',SUM(I),'  for ',EL(I)
        end do
      end if

      if ((mod(icycle,10)).eq.0) then
        leig_out = .true.
      end if

      if (myid == 0) then
        if (last.or.leig_out) then
          rewind(60)
          rewind(30)
          ievstart =1
          ies = 1
          do iblock = 1,nblock
            call eig_out(iblock,eigvec(ievstart),en(ies),z,isom_shift)
            ievstart = ievstart + ncfg_bl(iblock)*nume(iblock)
            ies = ies + nume(iblock)
          end do
        endif
      end if
      deallocate(isom_shift);
!       call MPI_Barrier(MPI_COMM_WORLD,ierr)
      end


c
c   Dint – version 2.0  is licensed under the Apache License, Version 2.0 (the "License");
c   you may not use Dint – version 2.0 except in compliance with the License.
c   You may obtain a copy of the License at
c       http://www.apache.org/licenses/LICENSE-2.0
c   The license is also given in the LICENSE file.
c   Unless required by applicable law or agreed to in writing, software
c   distributed under the License is distributed on an "AS IS" BASIS,
c   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
c   See the License for the specific language governing permissions and limitations under the License.
c
c -------------------------------------------------------------------------------------------
c  Dint : Direct Nonadiabatic Trajectories A code for non-Born–Oppenheimer molecular dynamics
c
c  version 2.0
c
c  A. W. Jasper
c  Argonne National Laboratory
c
c  Rui Ming Zhang
c  Tsinghua University
c
c  and
c
c  D. G. Truhlar
c  University of Minnesota
c
c  copyright  2020
c  Donald G. Truhlar and Regents of the University of Minnesota
c----------------------------------------------------------------------------------------------

c This file stores constants used for dimensioning arrays
c and for unit conversions.

c     max number of atom groups (aka molecules)
      integer mnmol
      parameter(mnmol=2)

c     max number of total atoms (total for all molecules)
      integer mnat
      parameter(mnat=100)

c     max number of electronic states
      integer mnsurf
      parameter(mnsurf=5)

c     max number of trajectories
      integer mntraj
      parameter(mntraj=1000000)

c     max number of termination condition outcomes
      integer mnoutcome
      parameter(mnoutcome=5)

c     maximum dimension of the Y-array that is integrated
      integer mnyarray
      parameter(mnyarray=6*mnat+5*mnsurf)

c     unit conversions
      double precision amutoau,kb,autoang,autoev,autofs,mu,autocmi,pi,
     & autokcal
      parameter(amutoau=1822.844987d0) ! best
c      parameter(amutoau=1822.888506d0) ! used by NAT
      parameter(kb=3.166829d-6)  ! Boltzmann in hartee/K
      parameter(autoang=0.52917706d0)
      parameter(autoev=27.2113961d0)
      parameter(autofs=0.024189d0)
      parameter(autocmi=219474.63067d0)
      parameter(autokcal=627.509d0)   ! IMLS
      parameter(mu=1.d0*amutoau)  ! mass-scaling mass
      parameter(pi=3.1415926536d0)