! File VersionID:
!   $Id: convertdiscrvert.for 205 2011-11-07 12:05:07Z kroes006 $
! ----------------------------------------------------------------------
      subroutine ConvertDiscrVert(SwDiscrvert,part,Swop,nrlevs,numlay,
     &         botcom,numnod,dz,h,theta,inq,inqrot,inqdra,
     &         IThetaBeg,Tsoil,cofgen,
     &         numnodNew,dzNew,botcomNew,hNew,thetaNew,inqNew,
     &         inqrotNew,inqdraNew,IThetaBegNew,TsoilNew,
     &         DiPoCp,FrArMtrx,IAvFrMpWlWtDm1,IAvFrMpWlWtDm2,
     &         IQExcMtxDm1Cp,IQExcMtxDm2Cp,IQOutDrRapCp,VlMpStDm1,
     &         VlMpStDm2,DiPoCpNew,IAvFrMpWlWtDm1New,IAvFrMpWlWtDm2New,
     &         IQExcMtxDm1CpNew,IQExcMtxDm2CpNew,IQOutDrRapCpNew,
     &         VlMpStDm1New,VlMpStDm2New,swsophy,numtab,sptab)
!***********************************************************************
!*    Routine: ConvertDiscrVert()
!*    Purpose: converts vertical descritization
!*    Usage:   Call ConvertDiscrVert(......)
!*    Author(s):
!*    Version:
!*    Date/history:
!*    See also:
!     Arguments:
!     I/O Data_type Name         Meaning
!      I     I4     SwDiscrVert
!      I     I4     part
!      I     I4     Swop
!      I     I4     logf         Unit number
!      I     I4     nrlevs
!      I     I4     numlay
!      I     I4     botcom(maho)
!      I     I4     numnod
!      I     R8     dz(macp)
!      I     R8     theta(macp)
!      I     R8     inq(macp)
!      I     R8     inqrot(macp)
!      I     R8     inqdra(macp)
!      I     R8     Tsoil(0:macp)
!      I     I4     numnodNew
!      I     R8     dzNew(macp)
!      I     R8     DiPoCp(macp)
!      I     R8     IAvFrMpWlWtDm1(macp)
!      I     R8     IAvFrMpWlWtDm2(macp)
!      I     R8     IQExcMtxDm1Cp(macp)
!      I     R8     IQExcMtxDm2Cp(macp)
!      I     R8     IQOutDrRapCp(macp)
!      I     R8     VlMpStDm1
!      I     R8     VlMpStDm2
!      O     I4     botcomNew(maho)
!      O     R8     thetaNew(macp)
!      O     R8     inqNew(macp)
!      O     R8     inqrotNew(macp)
!      O     R8     inqdraNew(macp)
!      O     R8     TsoilNew(0:macp)
!      O     R8     DiPoCpNew(macp)
!      O     R8     IAvFrMpWlWtDm1New(macp)
!      O     R8     IAvFrMpWlWtDm2New(macp)
!      O     R8     IQExcMtxDm1CpNew(macp)
!      O     R8     IQExcMtxDm2CpNew(macp)
!      O     R8     IQOutDrRapCpNew(macp)
!      O     R8     VlMpStDm1New(macp)
!      O     R8     VlMpStDm2New(macp)
!***********************************************************************
!---- Declarations
      IMPLICIT NONE
      include 'arrays.fi'
!     global
      integer   SwDiscrVert,part,Swop,numnod,numlay,numnodNew,nrlevs
      integer   botcom(maho),botcomNew(maho)
      real*8    cofgen(12,macp)
      real*8    dz(macp),h(macp),hNew(macp),theta(macp),
     &          inqrot(macp),inq(macp+1),inqdra(Madr,macp),Tsoil(0:macp)
      real*8    dzNew(macp),thetaNew(macp),
     &          inqrotNew(macp),inqNew(macp+1),
     &          inqdraNew(Madr,macp),TsoilNew(0:macp)
      real*8    IThetaBeg(MaCp), IThetaBegNew(MaCp)
      real*8    DiPoCp(macp), FrArMtrx(macp),IAvFrMpWlWtDm1(macp)
      real*8    IAvFrMpWlWtDm2(macp),IQExcMtxDm1Cp(macp)
      real*8    IQExcMtxDm2Cp(macp),IQOutDrRapCp(macp), VlMpStDm1(macp)
      real*8    VlMpStDm2(macp),DiPoCpNew(macp), IAvFrMpWlWtDm1New(macp)
      real*8    IAvFrMpWlWtDm2New(macp), IQExcMtxDm1CpNew(macp)
      real*8    IQExcMtxDm2CpNew(macp), IQOutDrRapCpNew(macp)
      real*8    VlMpStDm1New(macp), VlMpStDm2New(macp)
      integer   swsophy,numtab(macp)
      real*8    sptab(5,macp,matab)

!     local
      integer   lay,node,nodeN,nodeNew(macp,2),i,level
      real*8    disnodNew(macp+1),prhead,total,zNew(macp)
      real*8    CofgenNew(12,macp)
      character Message*80,ModuleName*80

      SAVE

! --- error in call of part
      if (part.lt.1 .or. part.gt.2) then
        write(message,*) 'fatal error in variabel PART '
        call fatalerr(ModuleName,message)
      endif

! --- always convert to maintain identic writing

      if(SwDiscrVert.eq.0) then
! --    Simply copy
        numnodNew = numnod
        do lay = 1,numlay
          botcomNew(lay) = botcom(lay)
        enddo
        do node = 1,numnodNew
          dzNew(node) = dz(node)
          hNew(node) = h(node)
          thetaNew(node) = theta(node)
          IThetaBegNew(node) = IThetaBeg(node)
          inqNew(node) = inq(node)
          inqrotNew(node) = inqrot(node)
          do level=1,nrlevs
            inqdraNew(level,node) = inqdra(level,node)
          enddo
!
          if (swop.eq.2) then
             VlMpStDm1New(node)     = VlMpStDm1(node)
             VlMpStDm2New(node)     = VlMpStDm2(node)
             DiPoCpNew(node)        = DiPoCp(node)
             IQExcMtxDm1CpNew(node) = IQExcMtxDm1Cp(node)
             IQOutDrRapCpNew(node)  = IQOutDrRapCp(node)
             IAvFrMpWlWtDm1New(node)= IAvFrMpWlWtDm1(node)
             IQExcMtxDm2CpNew(node) = IQExcMtxDm2Cp(node)
             IAvFrMpWlWtDm2New(node)= IAvFrMpWlWtDm2(node)
!
             ThetaNew(node)         = FrArMtrx(node)*Theta(node)
             IThetaBegNew(node)     = FrArMtrx(node)*IThetaBeg(node)
          endif
        enddo
        do node = 0,numnodNew
           TsoilNew(node) = Tsoil(node)
        enddo
        inqNew(numnodNew+1) = inq(numnod+1)

      else if(SwDiscrVert.eq.1) then
! ---   initial part (part 1)
        if (part.eq.1) then

!         calculate zNew = depth at bottom of new compartment
          Total = 0.0
          Do node = 1,numnodNew
            Total = Total + dzNew(node)
            zNew(node) = Total
          enddo
!         Fill array NodeNew(Numnod,1) = top old compartment and NodeNew(Numnod,2) = bottom old comp. in new comp. NodeN
          NodeN = 1
          Node = 1
          Total = 0.0
          do while (node.le.numnod)
            Total = Total + dz(node)
            If (ABS(zNew(NodeN)-Total).LT.1.0D-6) then
              NodeNew(NodeN,2) = Node
              NodeN = NodeN+1
            endif
            node = node+1
          enddo
          NodeNew(1,1) = 1
          Do node = 2,numnodNew
            NodeNew(Node,1) = NodeNew(Node-1,2)+1
          Enddo
!         botcomNew
          do lay = 1, numlay
            do node = 1,numnodNew
              if (NodeNew(Node,2).eq.botcom(lay)) then
                botcomNew(lay) = node
              else
                continue
              endif
            Enddo
          Enddo

!         for hNew: position of nodal points and distances between them
          zNew(1) = - 0.5*dzNew(1)
          disnodNew(1) = - zNew(1)
          do node = 2,numnodNew
            zNew(node) = zNew(node-1) - 0.5*(dzNew(node-1)+dzNew(node))
            disnodNew(node) = zNew(node-1)-zNew(node)
          enddo
!
        endif

! ---   In both part 1 and 2: convert theta to thetaNew based on weighed average
        Do node = 1,NumNodNew
          Total = 0.0
          Do i = NodeNew(node,1),NodeNew(node,2)
            Total = Total+dz(i)
          Enddo
          thetaNew(node) = 0.0
          IThetaBegNew(node) = 0.d0
          Do i = NodeNew(node,1),NodeNew(node,2)
            if (Swop.ne.2) then
               thetaNew(node) = thetaNew(node)+theta(i)*dz(i)/Total
               IThetaBegNew(node) = IThetaBegNew(node)+IThetaBeg(i)*
     &                              dz(i)/Total
            else
               thetaNew(node) = thetaNew(node)+FrArMtrx(i)*theta(i)*
     &                          dz(i)/Total
               IThetaBegNew(node) = IThetaBegNew(node)+FrArMtrx(i)*
     &                              IThetaBeg(i)*dz(i)/Total
            endif
          Enddo
        Enddo
! ---   convert Tsoil to TSoilNew based on weighed average
        Do node = 1,NumNodNew
          Total = 0.0
          Do i = NodeNew(node,1),NodeNew(node,2)
            Total = Total+dz(i)
          Enddo
          TsoilNew(node) = 0.0
          Do i = NodeNew(node,1),NodeNew(node,2)
            TsoilNew(node) = TsoilNew(node)+Tsoil(i)*dz(i)/Total
          Enddo
        Enddo

        if (swop.eq.2) then
! ---   convert VlMpStDm to VlMpStDmNew based on integration
           Do node = 1,NumNodNew
             VlMpStDm1New(node) = 0.0
             VlMpStDm2New(node) = 0.0
             Do i = NodeNew(node,1),NodeNew(node,2)
               VlMpStDm1New(node) = VlMpStDm1New(node) + VlMpStDm1(i)
               VlMpStDm2New(node) = VlMpStDm2New(node) + VlMpStDm2(i)
             Enddo
           Enddo
! ---   convert DiPoCp to DiPoCpNew based on weighed average
           Do node = 1,NumNodNew
             Total = 0.0
             Do i = NodeNew(node,1),NodeNew(node,2)
               Total = Total+dz(i)
             Enddo
             DiPoCpNew(node) = 0.0
             Do i = NodeNew(node,1),NodeNew(node,2)
               DiPoCpNew(node) = DiPoCpNew(node)+DiPoCp(i)*dz(i)/Total
             Enddo
           Enddo
        endif

! ---   only in dynamic part (part 2)
        if (part.eq.2) then

! -       Determine hNew
          do node = 1,numnodNew
!
! - Bug fixed: Rob H 28 okt 2011  !  this output for tabulated soil physics is suppressed
             do i = 1, 9
                cofgenNew(i,node) = cofgen(i,NodeNew(node,2)) ! CofgenNew Newnode = Cofgen bottom old node
             enddo

            hNew(node) = prhead (node,disnodNew(node),
     &               cofgenNew,thetaNew(node),hNew,swsophy,numtab,sptab)
          enddo

! ---     convert inqrot to inqrotNew based on integration
          Do node = 1,NumNodNew
            inqrotNew(node) = 0.0
            Do i = NodeNew(node,1),NodeNew(node,2)
              inqrotNew(node) = inqrotNew(node)+inqrot(i)
            Enddo
          Enddo
! ---     convert inq to inqNew
          Do node = 1,NumNodNew
            inqNew(node) = inq(NodeNew(node,1))
          Enddo
          inqNew(NumNodNew+1) = inq(numnod+1)
! ---     convert inqdra to inqdraNew based on integration
          Do level = 1,nrlevs
            Do node = 1,NumNodNew
              inqdraNew(level,node) = 0.0
              Do i = NodeNew(node,1),NodeNew(node,2)
                inqdraNew(level,node) = inqdraNew(level,node) +
     &                                 inqdra(level,i)
              Enddo
            Enddo
          Enddo
        endif

! ---   convert macropore fluxes to New fluxes based on integration, and
!       IAvFrMpWlWtDm1 to IAvFrMpWlWtDm1New, based on weighed average
        if (swop.eq.2) then
          Do node = 1,NumNodNew
            Total = 0.0
            Do i = NodeNew(node,1),NodeNew(node,2)
              Total = Total+dz(i)
            Enddo
            IQExcMtxDm1CpNew(node) = 0.0
            IQExcMtxDm2CpNew(node) = 0.0
            IQOutDrRapCpNew(node)  = 0.0
            IAvFrMpWlWtDm1New(node) = 0.0
            IAvFrMpWlWtDm2New(node) = 0.0
            Do i = NodeNew(node,1),NodeNew(node,2)
              IQExcMtxDm1CpNew(node) =
     &           IQExcMtxDm1CpNew(node) + IQExcMtxDm1Cp(i)
              IQExcMtxDm2CpNew(node) =
     &           IQExcMtxDm2CpNew(node) + IQExcMtxDm2Cp(i)
              IQOutDrRapCpNew(node) =
     &           IQOutDrRapCpNew(node)  + IQOutDrRapCp(i)
              IAvFrMpWlWtDm1New(node) =
     &           IAvFrMpWlWtDm1New(node) + IAvFrMpWlWtDm1(i)*dz(i)/Total
              IAvFrMpWlWtDm2New(node) =
     &           IAvFrMpWlWtDm2New(node) + IAvFrMpWlWtDm2(i)*dz(i)/Total
            Enddo
          Enddo
        endif

      else
        write(message,*) 'fatal error in variable SwDiscrVert'
        call fatalerr(ModuleName,message)
      endif

      return
      end


c----------------------------------------
c      Molecular orbitals from FMO/F
c         (and FMO/FX, FMO/XF)
c           totfock program
c       last updated Oct 28 2009
c   to be used to process output from
c        GAMESS FMO 3.3 and up
c        coded by D.G.Fedorov
c          RICS, AIST, Japan
c----------------------------------------
c
c     Usage: run FMO in GAMESS with $fmoprp mofock=7 $end .
c     If it was a GDDI parallel run, concatenate all punch files
c     (file naming depends upon the details in rungms, you should make sure
c     that all punch files are copied back to your home directory!)
c     cat job.dat job.F07.* > joball.dat
c     If you fail to collect punch files from all groups, nonsense will ensue
c     when running totfock.x .
c     Do not pipeline to totfock.x : it will work, but VERY slowly (why?!).
c     Compile this program (see comptot). Because of the comment below
c     numerious problems shall arise, no solution ever available!
c     To run, provide a concatenated punch file:
c     totfock.x <joball.dat >joball.res
c
c     This program is written in a most atrocious mixture of F77 and F90,
c     truly abhorable to the bone to be used in classroom as a stunning example
c     of an explamplary poor programming.
c
      program totfock
      implicit double precision (A-H,O-Z)
      character*17 aread,apatt
      character*1  jobz,range
      logical doe,dumpth
      integer, dimension(:), allocatable :: l,ian,ianb,ic,isuppz,iwork,
     *                                      iworks,lpart,map,ianbp
      double precision, dimension(:), allocatable :: a,t,h,E,V,s,SE,SV,
     *                                            work,works,apart,bflab
c
      apatt= 'TOTAL FOCK MATRIX'
c     ir=5
c     iw=6
c     jobz='N'
      jobz='V'
      range='A'
      vl=0
      vu=0
      il=0
      iu=0
c     For computing orbitals
      abstol=1.0D-10
      ispher=1
      qmttol=1.0d-06
c     If the total energy is to be computed (requires jobz.eq.'V').
      jl=0
      ju=0
c     For printing orbitals; if 0,0, nothing is printed, if -1,1, all is.
c
      ndimv=1
      ndimv2=1
  100 continue
        READ(*,9000,END=120,ERR=100) aread,natfmo,ichfmo,nefmo,mulfmo,
     *                         l0fmo,l1fmo,nbody,nlayer,nfg,maxl1,modpar
        if(aread.eq.apatt) then
          write(*,9010) natfmo,ichfmo,nefmo,mulfmo,l0fmo,l1fmo,nbody,
     *                  nlayer,nfg,maxl1,modpar
          if(jobz.eq.'V') ndimv=l1fmo
          dumpth=iand(modpar,4).ne.0
          doe=jobz.eq.'V'.and.dumpth
c         modpar:
c         1 set if dumping Fock from FMO enabled.
c         2 if exchange is added to Fock post factum.
c         4 if T+H (kinetic+1e Hamiltonian) are dumped, needed to do FMO/F.
          l2fmo=(l1fmo*l1fmo+l1fmo)/2
          if(doe) ndimv2=l2fmo
          lwork=26*l1fmo
          liwork=10*l1fmo
          lworks=l1fmo*l1fmo+6*l1fmo+1
          liworks=5*l1fmo+3
          maxl1d=maxl1*nbody
          maxl2d=(maxl1d*maxl1d+maxl1d)/2
          nafmo=nefmo/2
c         i.e., assuming singlet RHF
c         open shells can be added using mulfmo/nefmo.
          n=l1fmo
          n2=l2fmo
          allocate (a(n2),t(ndimv2),h(ndimv2),E(n),V(ndimv*ndimv),s(n2),
     *              SE(n),SV(n*n),l(n),ian(natfmo),ianb(n),ic(n),
     *              isuppz(2*n),work(lwork),iwork(liwork),works(lworks),
     *              iworks(liworks),bflab(ndimv),lpart(maxl1d),
     *              map(maxl1d),apart(maxl2d),ianbp(maxl1d))
c
          call diag(l1fmo, l2fmo, jobz, range, vl, vu, il, iu, abstol,
     *              ispher, qmttol, doe, dumpth, ndimv, ndimv2, lwork,
     *              liwork,lworks,liworks,jl,ju,nbody,nfg,maxl1d,
     *              maxl2d,nafmo,natfmo,e1,ef,a,t,h,E,V,s,SE,SV,l,ian,
     *              ianb,ic,isuppz,work,iwork,works,iworks,bflab,lpart,
     *              map,apart,ianbp)
c         deallocate(apart,map,lpart,iworks,works,iwork,work,isuppz,ic,
c    *               l,SV,SE,s,V,E,h,t,a)
          deallocate(a,t,h,E,V,s,SE,SV,l,ian,ianb,ic,isuppz,work,iwork,
     *               works,iworks,bflab,lpart,map,apart,ianbp)
          goto 120
        endif
      goto 100
  120 continue
 9000 format(1x,A17,I8,I4,I9,I3,2I9,I2,I2,I6,I6,I3)
 9010 format(1x,'FOUND FOCK MATRIX',I8,I4,I9,I3,2I9,I2,I2,I6,I6,I3)
      end

c call dsyevr(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z,
c ldz, isuppz, work, lwork, iwork, liwork, info)
c     dspevd(jobz, uplo, n, ap, w, z, ldz, work, lwork, iwork, liwork, info)

      subroutine diag(n, n2, jobz, range, vl, vu, il, iu, abstol,ispher,
     *                qmttol, doe, dumpth, ndimv, ndimv2, lwork,liwork,
     *                lworks,liworks,jl,ju,nbody,nfg,maxl1,maxl2,nafmo,
     *                natfmo,e1,ef,a,t,h,E,V,s,SE,SV,l,ian,ianb,ic,
     *                isuppz,work,iwork,works,iworks,bflab,lpart,map,
     *                apart,ianbp)
      implicit double precision (A-H,O-Z)
      parameter (MAXL=6,ZERO=0.0D+00,ONE=1.0D+00,toeV=27.21138386D+00)
      character*120 str
      character*20 aread,apatt,apatt2
      character*1  jobz,range
      logical doe,dumpth
      dimension a(n2),t(ndimv2),h(ndimv2),E(n),V(ndimv,ndimv),s(n2),
     *          SE(n),SV(n,n),l(n),ian(natfmo),ianb(n),ic(n),isuppz(2*n)
     *         ,work(lwork),iwork(liwork),works(lworks),iworks(liworks),
     *          bflab(ndimv)
      dimension lpart(maxl1),map(maxl1),apart(maxl2),ianbp(maxl1)
      dimension ln(0:MAXL),lm(0:MAXL),ts(1),tp(3,3),td(6,6),tf(10,10),
     *          tg(15,15),th(21,21),ti(28,28),r(28*28,0:MAXL)
c     save a,h,E,V,s,SE,SV,l,ic,isuppz,work,iwork,works,iworks,
c    *     lpart,map,apart
      DATA ln/1,3,6,10,15,21,28/
      DATA lm/1,3,5,7,9,11,13/
      DATA ts/1/
      DATA tp/1,0,0, 0,1,0, 0,0,1/
      DATA td/-0.5D+00,-0.5D+00,1, 0,0,0,
     *         0.866025403784439D+00,-0.866025403784439D+00,0,0,0,0,
     *         0,0,0,1,0,0,
     *         0,0,0,0,1,0,
     *         0,0,0,0,0,1,
     *         0,0,0,0,0,0/
      data tf/0.790569415042095D+00,0,0,0,0,
     *        -1.06066017177982D+00,0,0,0,0,
     *        0,0,0,0,0.866025403784438D+00,
     *        0,-0.866025403784438D+00,0,0,0,
     *        -0.612372435695794D+00,0,0,0,0,
     *        -0.273861278752583D+00,0,1.09544511501033D+00,0,0,
     *        0,0,1,0,-0.670820393249937D+00,
     *        0,-0.670820393249937D+00,0,0,0,
     *        0,-0.612372435695794D+00,0,-0.273861278752583D+00,0,
     *        0,0,0,1.09544511501033D+00,0,
     *        0,0,0,0,0, 0,0,0,0,1,
     *        0,-0.790569415042095D+00,0,1.06066017177982D+00,0,
     *        0,0,0,0,0,
     *        0,0,0,0,0, 0,0,0,0,0,
     *        0,0,0,0,0, 0,0,0,0,0,
     *        0,0,0,0,0, 0,0,0,0,0/
c
c     a(1,1)=0
c     a(2,1)=1
c     a(2,2)=0
c
c     First, assemble matrices a (F), s (S) and h (1e H)
c
      call dcopy(n2,0.0D+00,0,a,1)
      call dcopy(n2,0.0D+00,0,s,1)
      call dcopy(ndimv2,0.0D+00,0,t,1)
      call dcopy(ndimv2,0.0D+00,0,h,1)
      do i=1,n
        l(i)=-1
      enddo
      call dcopy(ln(0)*ln(0),ts,1,r(1,0),1)
      call dcopy(ln(1)*ln(1),tp,1,r(1,1),1)
      call dcopy(ln(2)*ln(2),td,1,r(1,2),1)
      call dcopy(ln(3)*ln(3),tf,1,r(1,3),1)
      call dcopy(ln(4)*ln(4),tg,1,r(1,4),1)
      call dcopy(ln(5)*ln(5),th,1,r(1,5),1)
      call dcopy(ln(6)*ln(6),ti,1,r(1,6),1)
      apatt='FRAGMENT FOCK MATRIX'
      apatt2='TOTAL FOCK NUCLEI='
      nblock=0
  100 continue
        READ(*,9000,END=120,ERR=100) str
c       write(*,*) 'read',str,'end'
        READ(str,9005,END=200,ERR=200) aread,icurlay,icurfg,jcurfg,
     *                                 kcurfg,l1,ifac
c       if came here, then read was succesful and a new n-mer was found
        goto 210
  200   continue
c       Try looking for the other string
        READ(str,9300,END=100,ERR=100) aread,enucr0
        if(aread.eq.apatt2) then
          enucr=enucr0
          write(*,9310) enucr
          read(*,9040,END=120,ERR=100) (ian(i),i=1,natfmo)
        endif
c
        goto 100
  210   continue
        l2=(l1*l1+l1)/2
        if(aread.eq.apatt) then
          read(*,9020,END=120,ERR=100) (map(i),i=1,l1)
          if(jcurfg.eq.0.and.kcurfg.eq.0) then
            read(*,9025,END=120,ERR=100) (lpart(i),i=1,l1)
            read(*,9315,END=120,ERR=100) (ianbp(i),i=1,l1)
          endif
          write(*,9010) icurlay,icurfg,jcurfg,kcurfg,l1,ifac
          if(ifac.ne.0) nblock=nblock+1
          nm=1
c         The order is: S
          if(ifac.ne.0) then
            nm=2
c           The order is: S+F
            if(dumpth) nm=4
c           The order is: S+T+H+F
          endif
c         loop (e.g.) over S (m=1), T (m=2), H (m=3) and F (m=4)
          do m=1,nm
            read(*,9030,END=120,ERR=100) (apart(i),i=1,l2)
            loop=0
            do i=1,l1
              im=map(i)
              if(jcurfg.eq.0.and.kcurfg.eq.0) then
                l(im)=lpart(i)
                ianb(im)=ianbp(i)
              endif
              do j=1,i
                loop=loop+1
                jm=map(j)
                if(im.ge.jm) then
                  ig=im
                  jg=jm
                else
                  ig=jm
                  jg=im
                endif
c               ig=max(im,jm)
c               jg=min(im,jm)
c               write(6,*) 'www',loop,ig,jg
                loopg=(ig*ig-ig)/2+jg
                if(m.eq.1) then
                  s(loopg)=apart(loop)
c                 overwrite S (not accumulate!)
                else if(m.eq.nm) then
                  a(loopg)=a(loopg)+ifac*apart(loop)
c                 Accumulate F
c                 a(ig,jg)=a(ig,jg)+ifac*apart(loop)
                else if(m.eq.2) then
                  t(loopg)=apart(loop)
c                 overwrite t (not accumulate!)
                else if(m.eq.3) then
                  h(loopg)=apart(loop)
c                 overwrite h (not accumulate!)
                endif
c               if(ig.ne.jg) a(ig,jg)=0
c               if(ig.gt.n) a(ig,jg)=0
              enddo
            enddo
          enddo
        endif
      goto 100
  120 continue
      nmonomer=nfg
      ndimer=(nfg*nfg-nfg)/2
      ntrimer=(nfg*nfg*nfg-3*nfg*nfg+2*nfg)/6
      ntotal=nmonomer
      if(nbody.gt.1) ntotal=ntotal+ndimer
      if(nbody.gt.2) ntotal=ntotal+ntrimer
      mblock=nblock-nmonomer
      mtotal=ntotal-nmonomer
      if(mtotal.eq.0) then
        sparse=0
      else
        sparse=1.0D+02-(mblock*1.0D+02)/mtotal
      endif
      write(*,9100) nblock,ntotal,sparse
c     write(*,*) 'L values for the basis set are:'
c     write(*,9025) l
c     write(*,*) 'ian'
c     write(*,9025) ian
c     write(*,*) 'ianb'
c     write(*,9025) ianb
c     write(*,*) 'Fock matrix is'
c     write(*,9030) a
c     write(*,*) 'Overlaps are'
c     write(*,9030) s
      if(doe) then
c       write(*,*) '1e ints are'
c       write(*,9030) h
      endif
      l1=n
      nsalc=l1
      if(jobz.eq.'V') call setlab(natfmo,l1,ln,l,ian,ianb,bflab)
      if(ispher.eq.1) call sphers(n,n2,l,s,ln,lm,r,nsalc,ic)
      l0=nsalc
c     write(*,9030) (s(i),i=1,(l0*l0+l0)/2)
      call dspevd('V', 'U', l0, s, SE, SV, n,
     *            works, lworks, iworks, liworks, info)
      neig=l0
      if(info.eq.0) then
        write(*,*) 'Diagonalisation of S was successful.'
        write(*,*) neig,' S eigenvalues found, matrix size=',n
        write(*,9200) (SE(i),i=1,neig)
      else
        write(*,*) 'Error occurred (see dspevd), info=',info
      endif
c     write(*,9030) ((SV(i,j),i=1,n),j=1,l0)
c
c     Construct Q=Xs^(-1/2), where SX=Xs
c
      do i=1,l0
        call dscal(n,1/sqrt(se(i)),sv(1,i),1)
      enddo
        write(*,*) 'Done rooting eigenvalues of S.'
      if(ispher.eq.1) then
        call spherv(l0,l,sv,n,ln,lm,r)
        write(*,*) 'Done transforming back eignevectors of S.'
      endif
      call TFTRI(s,a,SV,works(n*n+1),l0,l1,n)
      write(*,*) 'Done transforming F to orthogonal basis.'
      if(jl.eq.-1) jl=1
      if(ju.eq.-1) ju=l0
c
c     Expand triangular Qt*F*Q (stored in S) to square matrix
c
c     call dcopy(l0*l0,0.0D+00,0,works,1)
c     loop=0
c     do i=1,l0
c       do j=1,i
c         loop=loop+1
c         works(i+(j-1)*l0)=s(loop)
c       enddo
c     enddo
c     write(*,9030) s
c     write(*,9030) (works(i),i=1,n*n)
c
c     call dsyevr(jobz, range, 'L', l0, works, l0, vl, vu, il, iu,
c    *            abstol, neig, E, V, ndimv, isuppz, work, lwork, iwork,
c    *            liwork, info)
c     dsyevr produces wrong eignevectors for matrix size more than 13!!
      call dspevd(jobz, 'U', l0, s, E, V, ndimv,
     *            works, lworks, iworks, liworks, info)
      neig=l0
      if(info.eq.0) then
        write(*,*) 'Diagonalisation of F was successful.'
        write(*,*) neig,' F eigenvalues found, matrix size=',l0,ndimv
        write(*,9200) (E(i),i=1,neig)
        if(range.eq.'A') WRITE(*,9210) nafmo,nafmo+1,
     *                                 (e(nafmo+1)-e(nafmo))*toeV
c       do j=1,neig
c         if(jobz.eq.'V') write(*,9030) (v(i,j),i=1,l0)
c       enddo
c     Eigenvectors of F are back-transformed by Q.
      if(jobz.eq.'V') then
        write(*,*) 'Transforming back MOs...'
        CALL DGEMM('N','N',l1,l0,l0,ONE,sv,n,v,ndimv,ZERO,works,l1)
c
c       print orbitals.
c
        if(jl.gt.0.and.ju.gt.0)
     *    call PREVS(bflab,works,E,min(ju-jl+1,neig),l1,l1,jl)
        if(doe) then
          write(*,*) 'Done, computing 1e expectation values...',nafmo
          tkin=0
          e1=0
          ef=0
          nocc=2
          do i=1,min(nafmo,neig)
            call TFTRI(e1i,h,works((i-1)*l1+1),works(n*n+1),1,l1,n)
            call TFTRI(t1i,t,works((i-1)*l1+1),works(n*n+1),1,l1,n)
c           2 is the occupation number
            e1=e1+e1i*nocc
            tkin=tkin+t1i*nocc
            ef=ef+e(i)*nocc
          enddo
          e2=(ef-e1)/2
          etot=(e1+ef)/2+enucr
c         write(*,9300) ef,e1,(ef-e1)/2,(e1+ef)/2
c         Strictly speaking, range should be 'A' for the complete energy,
c         else it would be a partial contribution (may be interesting too?)
          E2 = ETOT - E1 - ENUCR
          VNE = E1 - TKIN
          VNN = ENUCR
          VEE = E2
          VTOT = VNE + VNN + VEE
          VIRIAL = -VTOT/TKIN
          WRITE(*,9320) E1,E2,ENUCR,ETOT
          WRITE(*,9330) VEE,VNE,VNN,VTOT,TKIN,VIRIAL
        endif
      endif
      else
        write(*,*) 'Error occurred (see dsyevr), info=',info
      endif
      return
 9000 format(1x,A120)
 9005 format(A20,I4,3I6,2I6)
c9008 FORMAT(I2,I3,1P,5E15.8)
 9010 format(1x,'FRAGMENT FOCK MATRIX',I4,3I6,2I6)
 9020 FORMAT(10I8)
 9025 FORMAT(40I2)
 9030 FORMAT(4E20.13)
 9040 format(1x,26I3)
 9100 FORMAT(1x,'Read',I9,' blocks, max',I9,', sparsity=',F8.2,' %')
 9200 FORMAT(6F13.6)
 9210 format(/1x,'HOMO=',I8,' , LUMO=',I8,' , gap=',F10.3,' eV',/)
c9300 FORMAT(/1x,'Total energies are:',
c    *       /1x,'   Fock matrix=   ',F20.10,
c    *       /1x,'  one electron=   ',F20.10,
c    *       /1x,'  two electron=   ',F20.10,
c    *       /1x,'total electron=   ',F20.10)
 9300 format(A18,F25.13)
 9310 format(1x,'TOTAL FOCK NUCLEI=',F25.13)
 9315 format(10I8)
 9320 FORMAT(/1X,'               ONE ELECTRON ENERGY =',F24.10/
     *        1X,'               TWO ELECTRON ENERGY =',F24.10/
     *        1X,'          NUCLEAR REPULSION ENERGY =',F24.10/
     *       38X,23(1H-)/
     *        1X,'                      TOTAL ENERGY =',F24.10)
 9330 FORMAT(/1X,'ELECTRON-ELECTRON POTENTIAL ENERGY =',F24.10/
     *        1X,' NUCLEUS-ELECTRON POTENTIAL ENERGY =',F24.10/
     *        1X,'  NUCLEUS-NUCLEUS POTENTIAL ENERGY =',F24.10/
     *       38X,23(1H-)/
     *        1X,'            TOTAL POTENTIAL ENERGY =',F24.10/
     *        1X,'              TOTAL KINETIC ENERGY =',F24.10/
     *        1X,'                VIRIAL RATIO (V/T) =',F24.10)
      end
      SUBROUTINE TFTRI(H,F,T,WRK,M,N,LDT)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION H(*),F(*),T(LDT,M),WRK(N)
      PARAMETER (MXROWS=5,zero=0.0D+00)
C
C     ----- TRANSFORM THE TRIANGULAR MATRIX F USING VECTORS T -----
C                      H = T-DAGGER * F * T
C     THE ORDER OF THE TRIANGULAR MATRICES H AND F ARE M AND N.
C
      IJ = 0
      DO 310 J = 1,M,MXROWS
         JJMAX = MIN(M,J+MXROWS-1)
C
C             FIRST CALCULATE T-DAGGER TIMES -F-, A ROW AT A TIME
C
         DO 300 JJ=J,JJMAX
            IK = 0
            DO 140 I = 1,N
               IM1 = I-1
               DUM = ZERO
               TDUM = T(I,JJ)
               IF (IM1.GT.0) THEN
                  DO 100 K = 1,IM1
                     IK = IK+1
                     WRK(K) = WRK(K)+F(IK)*TDUM
                     DUM = DUM+F(IK)*T(K,JJ)
  100             CONTINUE
               END IF
               IK = IK+1
               WRK(I) = DUM+F(IK)*TDUM
  140       CONTINUE
C
C             THEN TAKE THAT ROW TIMES EVERY COLUMN IN -T-
C
            DO 200 I = 1,JJ
               IJ = IJ+1
               HIJ = DDOT(N,T(1,I),1,WRK,1)
               H(IJ)=HIJ
  200       CONTINUE
  300    CONTINUE
  310 CONTINUE
C
      RETURN
      END
      SUBROUTINE sphers(n,n2,l,s,ln,lm,t,nsalc,ic)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      parameter (MAXL=6,ZERO=0.0D+00,ONE=1.0D+00)
      dimension l(n),s(n2),ln(0:MAXL),lm(0:MAXL),t(28*28,0:MAXL)
      dimension sb1(28,28),sb2(28,28)
      dimension ic(n)
c
c     Transform S to the spherical basis,
c     S'=Vt * S * V, where
c     V is the SALC matrix, block diagonal. Each AO forms a block
c     (one block for all components, such as px, py and pz).
c     V is not stored, instead blocks are taken from T indexed by l.
c     S' overwrites S.
c
      nsalc=0
      i=1
  100 continue
        li=l(i)
        lni=ln(li)
        lmi=lm(li)
        j=1
  200   continue
        lj=l(j)
        lnj=ln(lj)
        if(li.gt.1.or.lj.gt.1) then
c       otherwise T is a unit matrix
c         write(*,*) 'trans',i,j,li,lj,lni,lnj
          do im=1,lni
            loopi=i-1+im
            loopj=(loopi*loopi-loopi)/2+j-1
            maxj=lnj
            if(i.eq.j) maxj=im
            do jm=1,maxj
              loopj=loopj+1
              sb1(im,jm)=s(loopj)
c             write(6,*) im,jm,loopj,s(loopj)
            enddo
            if(i.eq.j) then
              loopj=(loopi*loopi-loopi)/2+j-1
              do jm=1,im-1
                loopj=loopj+1
                sb1(jm,im)=s(loopj)
c             write(6,*) jm,im,loopj,s(loopj)
              enddo
            endif
          enddo
c         if(i.eq.j) write(*,*) ((sb1(ii,jj),ii=1,lni),jj=1,lnj)
c         write(*,*) (t(ii,li),ii=1,lni*lni)
c         write(*,*) (t(ii,lj),ii=1,lnj*lnj)
c     DGEMM should be replaced by DCOPY for unit matrices
      CALL DGEMM('T','N',lni,lnj,lni,ONE,t(1,li),lni,sb1,28,ZERO,sb2,28)
c         write(*,*) ((sb2(ii,jj),ii=1,lni),jj=1,lnj)
      CALL DGEMM('N','N',lni,lnj,lnj,ONE,sb2,28,t(1,lj),lnj,ZERO,sb1,28)
c         write(*,*) ((sb1(ii,jj),ii=1,lni),jj=1,lnj)
c         Put the transformed block back into S
          do im=1,lni
            loopi=i-1+im
            loopj=(loopi*loopi-loopi)/2+j-1
            maxj=lnj
            if(i.eq.j) maxj=im
            do jm=1,maxj
              loopj=loopj+1
              s(loopj)=sb1(im,jm)
            enddo
          enddo
        endif
        j=j+lnj
        if(j.le.i) goto 200
        do im=1,lmi
          ic(i+im-1)=0
          nsalc=nsalc+1
        enddo
        do im=lmi+1,lni
          ic(i+im-1)=1
        enddo
        i=i+lni
      if(i.le.n) goto 100
c     write(*,*) '15th row',(s(105+ii),ii=1,15)
c     write(*,*)'15th col',(s(((14+ii)*(14+ii)+(14+ii))/2+15),ii=1,n-14)
c
c     Now purge zero rows and columns (spherical contaminants)
c
c     write(*,9030) s
      write(*,*) 'Purging',n-nsalc,' contaminants...'
c     write(*,*) (ic(ii),ii=1,n)
      loop1=0
      loop2=0
      do i=1,n
        do j=1,i
          loop1=loop1+1
          if(ic(i)+ic(j).eq.0) then
            loop2=loop2+1
            s(loop2)=s(loop1)
          endif
        enddo
      enddo
c
      RETURN
c9030 FORMAT(5E16.9)
      END
      SUBROUTINE spherv(l0,l,sv,n,ln,lm,t)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      parameter (MAXL=6,ZERO=0.0D+00,ONE=1.0D+00)
      dimension l(n),sv(n,l0),ln(0:MAXL),lm(0:MAXL)
      dimension t(28*28,0:MAXL),sb(28,28)
c
c     Transform back S eigenvectors (in-place)
c     X = V * X'
c     V is the SALC matrix, block diagonal. Each AO forms a block
c     (one block for all components, such as px, py and pz).
c     V is not stored, instead blocks are taken from T indexed by l.
c
c     Trudge to find the last block
c     write(*,9030) ((sv(i,j),j=1,l0),i=1,l0)
      i=1
      i0=1
  100 continue
        li=l(i)
        lni=ln(li)
        lmi=lm(li)
        i=i+lni
        i0=i0+lmi
      if(i0.le.l0) goto 100
c
  110 continue
c       This assumes that spherical components are consequent
        lip=l(i-1)
        i=i-ln(lip)
        i0=i0-lm(lip)
c       if(i0.lt.1) goto 300
        li=l(i)
        lni=ln(li)
        lmi=lm(li)
        j=1
  200   continue
          lj=l(j)
          lmj=lm(lj)
          if(li.gt.1) then
c           otherwise T is a unit matrix
c           write(*,*) 'trans',i,j,li,lj,lni,lmj
            CALL DGEMM('N','N',lni,lmj,lmi,ONE,t(1,li),lni,sv(i0,j),n,
     *                 ZERO,sb,28)
            do ii=lni-1,0,-1
              do jj=j,j+lmj-1
                sv(i+ii,jj)=sb(ii+1,jj-j+1)
              enddo
            enddo
          else
c           in this case lni=lmi and the V block is a unit matrix
            if(i.ne.i0) then
              do ii=lmi-1,0,-1
                do jj=j,j+lmj-1
                  sv(i+ii,jj)=sv(i0+ii,jj)
                enddo
              enddo
            endif
c           write(*,*) 'dcopy',i0,i,j,li,lj,lni,lmi,lmj,n
          endif
          j=j+lmj
        if(j.le.l0) goto 200
c     goto 110
      if(i.gt.1) goto 110
c 300 continue
c     write(*,9030) ((t(i+(j-1)*6,2),j=1,l0),i=1,n)
c     write(*,*) 'Q matrix'
c     do j=1,l0
c     write(*,9030) (sv(i,j),i=1,n)
c     enddo
c     write(iw,8030) ((q(i,j),j=l0,l0),i=1,l1)
c
      RETURN
c9030 FORMAT(6E13.5)
      END
C*MODULE MTHLIB  *DECK PREVS
      SUBROUTINE PREVS(bflab,V,E,NMO,NAO,LDV,ISTMO)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      DIMENSION V(LDV,NMO),E(NMO),bflab(nao)
C
C     ----- PRINT OUT EIGENDATA, WITH MO SYMMETRY LABELS -----
C     THE ROWS ARE LABELED WITH THE BASIS FUNCTION NAMES.
C
      MAX = 5
      IMAX = ISTMO-1
C
  100 IMIN = IMAX+1
      IMAX = IMAX+MAX
      IF (IMAX .GT. NMO) IMAX = NMO
      WRITE (*,9008)
      if(NAO.le.99999) then
        WRITE (*,9028) (I,     I=IMIN,IMAX)
        WRITE (*,9068) (E(I),  I=IMIN,IMAX)
        WRITE (*,9078) ('A   ',I=IMIN,IMAX)
        DO J = 1,NAO
          WRITE (*,9048) J,BFLAB(J),(V(J,I),I = IMIN,IMAX)
        enddo
      else
        WRITE (*,9029) (I,     I=IMIN,IMAX)
        WRITE (*,9069) (E(I),  I=IMIN,IMAX)
        WRITE (*,9079) ('A   ',I=IMIN,IMAX)
        DO J = 1,NAO
          WRITE (*,9049) J,BFLAB(J),(V(J,I),I = IMIN,IMAX)
        enddo
      endif
      IF (IMAX .LT. NMO) GO TO 100
      RETURN
 9008 FORMAT(1X)
 9028 FORMAT(15X,10(4X,I4,3X))
 9048 FORMAT(I5,2X,A8,10F11.6)
 9068 FORMAT(15X,10F11.4)
 9078 FORMAT(16X,10(5X,A4,2X))
 9029 FORMAT(18X,10(4X,I4,3X))
 9049 FORMAT(I8,2X,A8,10F11.6)
 9069 FORMAT(18X,10F11.4)
 9079 FORMAT(19X,10(5X,A4,2X))
      END
      subroutine setlab(natfmo,l1,ln,l,ian,ianb,bflab)
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
      parameter (MAXL=6)
      CHARACTER*6 BFNAM(35+49)
      CHARACTER*8 BFL
      dimension l(l1),ian(natfmo),ianb(l1),bflab(l1),ln(0:MAXL),
     *          loff(0:MAXL)
      CHARACTER*2 ATMLAB(104)
      data BFNAM/'  s ','  x ','  y ','  z ',
     *           ' xx ',' yy ',' zz ',' xy ',' xz ',' yz ',
     *           ' xxx',' yyy',' zzz',' xxy',' xxz',
     *           ' yyx',' yyz',' zzx',' zzy',' xyz',
     *           'xxxx','yyyy','zzzz','xxxy','xxxz',
     *           'yyyx','yyyz','zzzx','zzzy','xxyy',
     *           'xxzz','yyzz','xxyz','yyxz','zzxy',
     *           ' xxxxx',' yyyyy',' zzzzz',' xxxxy',' xxxxz',
     *           ' yyyyx',' yyyyz',' zzzzx',' zzzzy',' xxxyy',
     *           ' xxxzz',' yyyxx',' yyyzz',' zzzxx',' zzzyy',
     *           ' xxxyz',' yyyxz',' zzzxy',' xxyyz',' xxzzy',
     *           ' yyzzx',
     *           '    x6','    y6','    z6','   x5y','   x5z',
     *           '   y5x','   y5z','   z5x','   z5y','  x4y2',
     *           '  x4z2','  y4x2','  y4z2','  z4x2','  z4y2',
     *           '  x4yz','  y4xz','  z4xy','  x3y3','  x3z3',
     *           '  y3z3',' x3y2z',' x3z2y',' y3x2z',' y3z2x',
     *           ' z3x2y',' z3y2x','x2y2z2'/
C
C     104 TRUE ELEMENTS
C
      DATA ATMLAB/'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',
     *            'Na','Mg','Al','Si','P ','S ','Cl','Ar','K ','Ca',
     *            'Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu','Zn',
     *            'Ga','Ge','As','Se','Br','Kr','Rb','Sr','Y ','Zr',
     *            'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn',
     *            'Sb','Te','I ','Xe','Cs','Ba','La','Ce','Pr','Nd',
     *            'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb',
     *            'Lu','Hf','Ta','W ','Re','Os','Ir','Pt','Au','Hg',
     *            'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th',
     *            'Pa','U ','Np','Pu','Am','Cm','Bk','Cf','Es','Fm',
     *            'Md','No','Lr','Rf'/
      data loff/1,2,5,11,21,36,57/
c
      i=1
  100 continue
        li=l(i)
        lni=ln(li)
        loffi=loff(li)
        do j=1,lni
          IF(li.LE.4) THEN
            iat=ianb(i)
            WRITE(UNIT=BFL,FMT='(A2,I2,A4)')
     *        atmlab(ian(iat)),MOD(IAT,100),BFNAM(loffi+j-1)
          ELSE
            WRITE(UNIT=BFL,FMT='(A2,A6)')
     *        atmlab(ian(iat)),BFNAM(loffi+j-1)
          END IF
          READ (UNIT=BFL,FMT='(A8)') BFLAB(i)
          i=i+1
        enddo
      if(i.le.l1) goto 100
      RETURN
      END


SUBROUTINE trans(bcmstandstem,bcmstandleaf,bcmstandstore,bcmflatstem,           &
               & bcmflatleaf,bcmflatstore,bcmflatrootstore,bcmflatrootfiber,    &
               & bcmbgstemz,bcmbgleafz,bcmbgstorez,bcmbgrootstorez,             &
               & bcmbgrootfiberz,bczht,bcdstm,bcxstmrep,bcgrainf,bdmstandstem,  &
               & bdmstandleaf,bdmstandstore,bdmflatstem,bdmflatleaf,            &
               & bdmflatstore,bdmflatrootstore,bdmflatrootfiber,bdmbgstemz,     &
               & bdmbgleafz,bdmbgstorez,bdmbgrootstorez,bdmbgrootfiberz,bdzht,  &
               & bddstm,bdxstmrep,bdgrainf,bc0nam,bcxstm,bcrbc,bc0sla,bc0ck,    &
               & bcdkrate,bccovfact,bcddsthrsh,bchyfg,bcresevapa,bcresevapb,    &
               & bd0nam,bdxstm,bdrbc,bd0sla,bd0ck,bdkrate,bcovfact,bddsthrsh,   &
               & bdhyfg,bdresevapa,bdresevapb,bcumdds,bcumddf,bcumddg,nslay)
IMPLICIT NONE
!
INCLUDE 'p1werm.inc'
!
! Subroutine arguments
!
REAL :: bc0ck,bc0sla,bccovfact,bcddsthrsh,bcdstm,bcgrainf,bcmflatleaf,          &
      & bcmflatrootfiber,bcmflatrootstore,bcmflatstem,bcmflatstore,bcmstandleaf,&
      & bcmstandstem,bcmstandstore,bcresevapa,bcresevapb,bcxstm,bcxstmrep,bczht
CHARACTER(80) :: bc0nam
INTEGER :: bchyfg,bcrbc,nslay
REAL,DIMENSION(mndk) :: bcdkrate
REAL,DIMENSION(mnsz) :: bcmbgleafz,bcmbgrootfiberz,bcmbgrootstorez,bcmbgstemz,  &
                      & bcmbgstorez
REAL,DIMENSION(mnbpls) :: bcovfact,bcumddf,bcumdds,bd0ck,bd0sla,bddsthrsh,      &
                        & bddstm,bdgrainf,bdmflatleaf,bdmflatrootfiber,         &
                        & bdmflatrootstore,bdmflatstem,bdmflatstore,            &
                        & bdmstandleaf,bdmstandstem,bdmstandstore,bdresevapa,   &
                        & bdresevapb,bdxstm,bdxstmrep,bdzht
REAL,DIMENSION(mnsz,mnbpls) :: bcumddg,bdmbgleafz,bdmbgrootfiberz,              &
                             & bdmbgrootstorez,bdmbgstemz,bdmbgstorez
CHARACTER(80),DIMENSION(mnbpls) :: bd0nam
INTEGER,DIMENSION(mnbpls) :: bdhyfg,bdrbc
REAL,DIMENSION(mndk,mnbpls) :: bdkrate
!
! Local variables
!
INTEGER :: idk,ip,lay
!
!     + + + purpose + + +
!
!     this subroutine performs the biomass manipulation of transferring
!     biomass.  transfer of biomass is performed on both the standing
!     or above ground biomass and the root biomass.  the transfer is
!     from the "temporary" crop pool to the decomp biomass pools
!     (when called from within "doeffect".

!     + + + keywords + + +
!     transfer, biomass manipulation

!     + + + argument declarations + + +
!
!     + + + argument definitions + + +
!
!     nslay       - number of soil layers
!
!     + + + accessed common block variable definitions + + +
!
!     mnbpls        - max number of decomposition pools (currently=3)
!     mnsz          - max number of soil layers
!     mndk          - max number of decay coefficients
!
!     + + + parameters + + +
!
!     + + + local variables + + +
!
!
!     + + + local variable definitions + + +
!
!     lay        - soil layer index
!     ip         - decomp pool index
!     idk        - dkrate components index
!     idx        - crop mass by height index

!     + + + end specifications + + +

! transfer standing residue height and diameter, and grain fraction
DO ip = mnbpls,2, - 1                   !added state
  bdzht(ip) = bdzht(ip-1)
  bdxstm(ip) = bdxstm(ip-1)
  bdxstmrep(ip) = bdxstmrep(ip-1)
  bdgrainf(ip) = bdgrainf(ip-1)
  bdhyfg(ip) = bdhyfg(ip-1)
END DO
bdzht(1) = bczht
bdxstm(1) = bcxstm
bdxstmrep(1) = bcxstmrep
bdgrainf(1) = bcgrainf
bczht = 0.0
bcgrainf = 0.0
      ! do not zero out, this still applies if the crop has not been killed
      ! bcxstm = 0.0
      ! do not zero out, this still applies until it is recalculated
      ! bcxstmrep = 0.0

! transfer stem numbers
bddstm(mnbpls) = bddstm(mnbpls) + bddstm(mnbpls-1)
DO ip = mnbpls - 1,2, - 1
  bddstm(ip) = bddstm(ip-1)
END DO
bddstm(1) = bcdstm
bcdstm = 0.0

      ! add next to last pool biomass to last pool biomass
      ! surface pools
bdmstandstem(mnbpls) = bdmstandstem(mnbpls) + bdmstandstem(mnbpls-1)
bdmstandleaf(mnbpls) = bdmstandleaf(mnbpls) + bdmstandleaf(mnbpls-1)
bdmstandstore(mnbpls) = bdmstandstore(mnbpls) + bdmstandstore(mnbpls-1)
bdmflatstem(mnbpls) = bdmflatstem(mnbpls) + bdmflatstem(mnbpls-1)
bdmflatleaf(mnbpls) = bdmflatleaf(mnbpls) + bdmflatleaf(mnbpls-1)
bdmflatstore(mnbpls) = bdmflatstore(mnbpls) + bdmflatstore(mnbpls-1)
bdmflatrootstore(mnbpls) = bdmflatrootstore(mnbpls) + bdmflatrootstore(mnbpls-1)
bdmflatrootfiber(mnbpls) = bdmflatrootfiber(mnbpls) + bdmflatrootfiber(mnbpls-1)
      ! below ground by layer
DO lay = 1,nslay
  bdmbgstemz(lay,mnbpls) = bdmbgstemz(lay,mnbpls) + bdmbgstemz(lay,mnbpls-1)
  bdmbgleafz(lay,mnbpls) = bdmbgleafz(lay,mnbpls) + bdmbgleafz(lay,mnbpls-1)
  bdmbgstorez(lay,mnbpls) = bdmbgstorez(lay,mnbpls) + bdmbgstorez(lay,mnbpls-1)
  bdmbgrootstorez(lay,mnbpls) = bdmbgrootstorez(lay,mnbpls)                     &
                              & + bdmbgrootstorez(lay,mnbpls-1)
  bdmbgrootfiberz(lay,mnbpls) = bdmbgrootfiberz(lay,mnbpls)                     &
                              & + bdmbgrootfiberz(lay,mnbpls-1)
END DO

      ! transfer biomass down one level in pools
DO ip = mnbpls - 1,2, - 1
          ! surface pools
  bdmstandstem(ip) = bdmstandstem(ip-1)
  bdmstandleaf(ip) = bdmstandleaf(ip-1)
  bdmstandstore(ip) = bdmstandstore(ip-1)
  bdmflatstem(ip) = bdmflatstem(ip-1)
  bdmflatleaf(ip) = bdmflatleaf(ip-1)
  bdmflatstore(ip) = bdmflatstore(ip-1)
  bdmflatrootstore(ip) = bdmflatrootstore(ip-1)
  bdmflatrootfiber(ip) = bdmflatrootfiber(ip-1)
          ! below ground by layer
  DO lay = 1,nslay
     bdmbgstemz(lay,ip) = bdmbgstemz(lay,ip-1)
     bdmbgleafz(lay,ip) = bdmbgleafz(lay,ip-1)
     bdmbgstorez(lay,ip) = bdmbgstorez(lay,ip-1)
     bdmbgrootstorez(lay,ip) = bdmbgrootstorez(lay,ip-1)
     bdmbgrootfiberz(lay,ip) = bdmbgrootfiberz(lay,ip-1)
  END DO
END DO

      ! transfer incoming biomass into first pool
      ! surface pools
bdmstandstem(1) = bcmstandstem
bdmstandleaf(1) = bcmstandleaf
bdmstandstore(1) = bcmstandstore
bdmflatstem(1) = bcmflatstem
bdmflatleaf(1) = bcmflatleaf
bdmflatstore(1) = bcmflatstore
bdmflatrootstore(1) = bcmflatrootstore
bdmflatrootfiber(1) = bcmflatrootfiber
      ! below ground by layer
DO lay = 1,nslay
  bdmbgstemz(lay,1) = bcmbgstemz(lay)
  bdmbgleafz(lay,1) = bcmbgleafz(lay)
  bdmbgstorez(lay,1) = bcmbgstorez(lay)
  bdmbgrootstorez(lay,1) = bcmbgrootstorez(lay)
  bdmbgrootfiberz(lay,1) = bcmbgrootfiberz(lay)
END DO

      ! zero out the incoming biomass
      ! surface pools
bcmstandstem = 0.0
bcmstandleaf = 0.0
bcmstandstore = 0.0
bcmflatstem = 0.0
bcmflatleaf = 0.0
bcmflatstore = 0.0
bcmflatrootstore = 0.0
bcmflatrootfiber = 0.0
      ! below ground by layer
DO lay = 1,nslay
  bcmbgstemz(lay) = 0.0
  bcmbgleafz(lay) = 0.0
  bcmbgstorez(lay) = 0.0
  bcmbgrootstorez(lay) = 0.0
  bcmbgrootfiberz(lay) = 0.0
END DO

! transfer cumm ddays for s standing, f flat, and g below ground pools
DO ip = mnbpls,2, - 1
  bcumdds(ip) = bcumdds(ip-1)
  bcumddf(ip) = bcumddf(ip-1)
  DO lay = 1,nslay
     bcumddg(lay,ip) = bcumddg(lay,ip-1)
  END DO
END DO
bcumdds(1) = 0.0          ! reset cummdds to zero
bcumddf(1) = 0.0          ! reset cummddf to zero
DO lay = 1,nslay
  bcumddg(lay,1) = 0.0           ! reset cummddg to zero
END DO

! transfer decay rates for standing, flat, below ground, roots,
! stem_no pools, and harvestable yield flag
DO idk = 1,mndk
  DO ip = mnbpls,2, - 1
     bdkrate(idk,ip) = bdkrate(idk,ip-1)
  END DO
  bdkrate(idk,1) = bcdkrate(idk)
          ! do not zero out, this still applies if the crop has not been killed
          ! bcdkrate(idk) = 0.0
END DO

DO ip = mnbpls,2, - 1
  bd0nam(ip) = bd0nam(ip-1)
  bdrbc(ip) = bdrbc(ip-1)
  bd0sla(ip) = bd0sla(ip-1)
  bd0ck(ip) = bd0ck(ip-1)
  bcovfact(ip) = bcovfact(ip-1)
  bddsthrsh(ip) = bddsthrsh(ip-1)
  bdhyfg(ip) = bdhyfg(ip-1)
  bdresevapa(ip) = bdresevapa(ip-1)
  bdresevapb(ip) = bdresevapb(ip-1)
END DO
bd0nam(1) = bc0nam
bdrbc(1) = bcrbc
bd0sla(1) = bc0sla
bd0ck(1) = bc0ck
bcovfact(1) = bccovfact
bddsthrsh(1) = bcddsthrsh
bdhyfg(1) = bchyfg
bdresevapa(1) = bcresevapa
bdresevapb(1) = bcresevapb
      ! do not zero out, this still applies if the crop has not been killed
      ! bc0nam = ""
      ! bcrbc = 0
      ! bc0sla = 0.0
      ! bccovfact = 0.0
      ! bcddsthrsh = 0.0
      ! bchyfg = 0.0
!
END SUBROUTINE trans

Project Documents/Source Code Original/Trans.f90


module tcp_setup
  implicit none
  private
  public:: setup
        interface setup; module procedure setuptcp; end interface

contains
subroutine setuptcp(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsave)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:    setuptcp                     setup tcpel data
!   prgmmr: kleist            org: np20                date: 2009-02-02
!
! abstract:  Setup routine for TC MSLP data
!
! program history log:
!   2009-02-02  kleist
!   2009-08-19  guo     - changed for multi-pass setup with dtime_check().
!   2010-05-25  kleist  - output tc_ps observations to conv diag file
!   2010-11-24  todling - add component to write obs sensitiviy to diag file
!   2013-01-26  parrish - change grdcrd to grdcrd1, intrp2a to intrp2a11,
!                          tintrp2a to tintrp2a1, tintrp2a11 (so debug compile works on WCOSS)
!   2013-10-19  todling - metguess now holds background
!   2014-01-28  todling - write sensitivity slot indicator (idia) to header of diagfile
!   2014-12-30  derber - Modify for possibility of not using obsdiag
!   2015-10-01  guo   - full res obvsr: index to allow redistribution of obsdiags
!   2016-05-18  guo     - replaced ob_type with polymorphic obsNode through type casting
!   2016-06-24  guo     - fixed the default value of obsdiags(:,:)%tail%luse to luse(i)
!                       . removed (%dlat,%dlon) debris.
!   2016-11-29  shlyaeva - save linearized H(x) for EnKF
!   2017-02-09  guo     - Remove m_alloc, n_alloc.
!                       . Remove my_node with corrected typecast().
!   2020-02-26  todling - reset obsbin from hr to min
!
!   input argument list:
!
!   output argument list:
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
  use mpeu_util, only: die,perr,getindex
  use state_vectors, only: ns3d, svars2d, levels, nsdim
  use sparsearr, only: sparr2, new, size, writearray, fullarray
  use kinds, only: r_kind,i_kind,r_single,r_double
  use m_obsdiagNode, only: obs_diag
  use m_obsdiagNode, only: obs_diags
  use m_obsdiagNode, only: obsdiagLList_nextNode
  use m_obsdiagNode, only: obsdiagNode_set
  use m_obsdiagNode, only: obsdiagNode_get
  use m_obsdiagNode, only: obsdiagNode_assert

  use obsmod, only:  &
             nobskeep,lobsdiag_allocated,oberror_tune,perturb_obs, &
             time_offset,rmiss_single,lobsdiagsave,lobsdiag_forenkf,ianldate
  use obsmod, only: netcdf_diag, binary_diag, dirname
  use nc_diag_write_mod, only: nc_diag_init, nc_diag_header, nc_diag_metadata, &
       nc_diag_write, nc_diag_data2d
  use nc_diag_read_mod, only: nc_diag_read_init, nc_diag_read_get_dim, nc_diag_read_close
  use m_obsNode, only: obsNode
  use m_tcpNode, only: tcpNode
  use m_tcpNode, only: tcpNode_appendto
  use m_obsLList, only: obsLList
  use obsmod, only: luse_obsdiag
  use gsi_4dvar, only: nobs_bins,mn_obsbin
  use qcmod, only: npres_print
  use guess_grids, only: ges_lnprsl,nfldsig,hrdifsig, &
          ntguessig
  use gridmod, only: get_ij,nsig
  use constants, only: zero,half,one,tiny_r_kind,two,cg_term, &
          wgtlim,g_over_rd,huge_r_kind,pi,huge_single,tiny_single,r10,r1000
  use convinfo, only: nconvtype,cermin,cermax,cgross,cvar_b,cvar_pg,ictype,&
          icsubtype
  use jfunc, only: jiter,last,jiterstart,miter
  use m_dtime, only: dtime_setup, dtime_check
  use gsi_bundlemod, only : gsi_bundlegetpointer
  use gsi_metguess_mod, only : gsi_metguess_get,gsi_metguess_bundle
  implicit none

  type(obsLList ),target,dimension(:),intent(inout):: obsLL
  type(obs_diags),target,dimension(:),intent(inout):: odiagLL

  integer(i_kind)                                  ,intent(in   ) :: lunin,mype,nele,nobs
  integer(i_kind)                                  ,intent(in   ) :: is ! ndat index

  real(r_kind),dimension(npres_print,nconvtype,5,3),intent(inout) :: bwork ! obs-ges stats
  real(r_kind),dimension(100+7*nsig)               ,intent(inout) :: awork ! data counts and gross checks

  logical                                          ,intent(in)    :: conv_diagsave

! Declare external calls for code analysis
  external:: intrp2a11,tintrp2a1,tintrp2a11
  external:: tintrp3
  external:: grdcrd1
  external:: stop2

! DECLARE LOCAL PARMS HERE
  real(r_double) rstation_id
  character(8) station_id
  equivalence(rstation_id,station_id)

  logical,dimension(nobs):: luse,muse
  integer(i_kind),dimension(nobs):: ioid ! initial (pre-distribution) obs ID
  logical proceed

  real(r_kind) err_input,err_adjst,err_final,errinv_input,errinv_adjst,errinv_final
  real(r_kind) scale,ratio,obserror,obserrlm
  real(r_kind) residual,ress,ressw2,val,val2
  real(r_kind) valqc,tges,tges2
  real(r_kind) wgross,wnotgross,wgt,arg,exp_arg,term,rat_err2
  real(r_kind) rwgt,cg_ps,drbx
  real(r_kind) error,dtime,dlon,dlat,r0_001,r2_5,r0_2,rsig
  real(r_kind) ratio_errors,psges,zsges,rdp,drdp
  real(r_kind) pob,pges,pgesorig,half_tlapse,ddiff,halfpi,r0_005,rdelz,psges2

  real(r_kind),dimension(nele,nobs):: data
  real(r_kind),dimension(nsig)::prsltmp,tvges

  type(sparr2) :: dhx_dx
  real(r_single), dimension(nsdim) :: dhx_dx_array
  integer(i_kind) :: ps_ind, nind, nnz

  integer(i_kind) i,jj
  integer(i_kind) mm1,idia,idia0
  integer(i_kind) ikxx,nn,iuse,ibin,iptrb,id
  integer(i_kind) ier,ilon,ilat,ipres,itime,ikx,ilate,ilone

  logical:: in_curbin, in_anybin, save_jacobian
  type(tcpNode),pointer:: my_head
  type(obs_diag),pointer:: my_diag
  type(obs_diags),pointer:: my_diagLL

  character(len=*),parameter:: myname='setuptcp'

  character(8),allocatable,dimension(:):: cdiagbuf
  real(r_single),allocatable,dimension(:,:)::rdiagbuf
  integer(i_kind) nchar,nreal,ii

  real(r_kind),allocatable,dimension(:,:,:  ) :: ges_ps
  real(r_kind),allocatable,dimension(:,:,:  ) :: ges_z
  real(r_kind),allocatable,dimension(:,:,:,:) :: ges_tv

  type(obsLList),pointer,dimension(:):: tcphead
  tcphead => obsLL(:)

  save_jacobian = conv_diagsave .and. jiter==jiterstart .and. lobsdiag_forenkf

! Check to see if required guess fields are available
  call check_vars_(proceed)
  if(.not.proceed) return  ! not all vars available, simply return

! If require guess vars available, extract from bundle ...
  call init_vars_

!******************************************************************************
! Read and reformat observations in work arrays.
  read(lunin)data,luse,ioid

!    index information for data array (see reading routine)
  ier=1       ! index of obs error
  ilon=2      ! index of grid relative obs location (x)
  ilat=3      ! index of grid relative obs location (y)
  ipres=4     ! index of pressure
  itime=5     ! index of time observation
  ikxx=6      ! index of observation type in data array
  ilone=7     ! index of longitude (degrees)
  ilate=8     ! index of latitude (degrees)
  iuse=9      ! index of usage parameter
  id=10       ! index of storm name

  mm1=mype+1
  scale=one
  rsig=nsig
  halfpi = half*pi
  r0_005 = 0.005_r_kind
  r0_2=0.2_r_kind
  r2_5=2.5_r_kind
  half_tlapse=0.00325_r_kind  ! half of 6.5K/1km
  r0_001=0.001_r_kind

  do i=1,nobs
     muse(i)=nint(data(iuse,i)) <= jiter
  end do

  if(conv_diagsave)then
     nchar=1
     idia0=20
     nreal=idia0
     if (lobsdiagsave) nreal=nreal+4*miter+1
     if (save_jacobian) then
       nnz   = 1
       nind   = 1
       call new(dhx_dx, nnz, nind)
       nreal = nreal + size(dhx_dx)
     endif
     allocate(cdiagbuf(nobs),rdiagbuf(nreal,nobs))
     ii=0
     if(netcdf_diag) call init_netcdf_diag_
  end if

  call dtime_setup()
  do i=1,nobs
     dtime=data(itime,i)
     call dtime_check(dtime, in_curbin, in_anybin)
     if(.not.in_anybin) cycle

     if(in_curbin) then
        dlat=data(ilat,i)
        dlon=data(ilon,i)
        pob=data(ipres,i)

        error=data(ier,i)
        ikx=nint(data(ikxx,i))
     endif

!    Link observation to appropriate observation bin
     if (nobs_bins>1) then
        ibin = NINT( dtime*60/mn_obsbin ) + 1
     else
        ibin = 1
     endif
     IF (ibin<1.OR.ibin>nobs_bins) write(6,*)mype,'Error nobs_bins,ibin= ',nobs_bins,ibin

     if ( luse_obsdiag ) my_diagLL => odiagLL(ibin)

!    Link obs to diagnostics structure
     if ( luse_obsdiag ) then
        my_diag => obsdiagLList_nextNode(my_diagLL      ,&
                create = .not.lobsdiag_allocated        ,&
                   idv = is             ,&
                   iob = ioid(i)        ,&
                   ich = 1              ,&
                  elat = data(ilate,i)  ,&
                  elon = data(ilone,i)  ,&
                  luse = luse(i)        ,&
                 miter = miter          )

        if(.not.associated(my_diag)) call die(myname, &
                'obsdiagLList_nextNode(), create =',.not.lobsdiag_allocated)
     endif

     if(.not.in_curbin) cycle

! Get guess sfc hght at obs location
     call intrp2a11(ges_z(1,1,ntguessig),zsges,dlat,dlon,mype)

! Interpolate to get log(ps) and log(pres) at mid-layers
! at obs location/time
     call tintrp2a11(ges_ps,psges,dlat,dlon,dtime,hrdifsig,&
        mype,nfldsig)
     call tintrp2a1(ges_lnprsl,prsltmp,dlat,dlon,dtime,hrdifsig,&
        nsig,mype,nfldsig)
     call tintrp2a1(ges_tv,tvges,dlat,dlon,dtime,hrdifsig,&
        nsig,mype,nfldsig)

! Convert pressure to grid coordinates
     pgesorig = psges

! Take log for vertical interpolation
     psges = log(psges)
     call grdcrd1(psges,prsltmp,nsig,-1)

! Get guess temperature at observation location and surface
     call tintrp31(ges_tv,tges,dlat,dlon,psges,dtime, &
          hrdifsig,mype,nfldsig)

! Adjust observation error and obs value due to differences in surface height
     rdelz=-zsges

!  No observed temperature
     psges2=data(ipres,i)
     call grdcrd1(psges2,prsltmp,nsig,-1)
     call tintrp31(ges_tv,tges2,dlat,dlon,psges2,dtime, &
          hrdifsig,mype,nfldsig)

     drbx = half*abs(tges-tges2)+r2_5+r0_005*abs(rdelz)
     tges = half*(tges+tges2)

! Extrapolate surface temperature below ground at 6.5 k/km
! note only extrapolating .5dz, if no surface temp available.
     if(rdelz < zero)then
        tges=tges-half_tlapse*rdelz
        drbx=drbx-half_tlapse*rdelz
     end if

! Adjust guess hydrostatically
     rdp = g_over_rd*rdelz/tges

! Subtract off dlnp correction, then convert to pressure (cb)
     pges = exp(log(pgesorig) - rdp)

     if (save_jacobian) then
        ps_ind = getindex(svars2d, 'ps')
        if (ps_ind < 0) then
           print *, 'Error: no variable ps in state vector. Exiting.'
           call stop2(1300)
        endif

        dhx_dx%st_ind(1) = sum(levels(1:ns3d)) + ps_ind
        dhx_dx%end_ind(1) = sum(levels(1:ns3d)) + ps_ind
        dhx_dx%val(1) = one
     endif

! Compute innovations
     ddiff=pob-pges  ! in cb

! Oberror Tuning and Perturb Obs
     if(muse(i)) then
        if(oberror_tune )then
           if( jiter > jiterstart ) then
              ddiff=ddiff+data(iptrb,i)/error/ratio_errors
           endif
        else if(perturb_obs )then
           ddiff=ddiff+data(iptrb,i)/error/ratio_errors
        endif
     endif

! observational error adjustment
     drdp = pges*(g_over_rd*abs(rdelz)*drbx/(tges**2))

!  find adjustment to observational error (in terms of ratio)
     ratio_errors=error/(error+drdp)
     error=one/error

!    Gross error checks
     obserror = min(r10/max(ratio_errors*error,tiny_r_kind),huge_r_kind)
     obserrlm = max(cermin(ikx),min(cermax(ikx),obserror))
     residual = abs(r10*ddiff)
     ratio    = residual/obserrlm
     if (ratio > cgross(ikx) .or. ratio_errors < tiny_r_kind) then
        if (luse(i)) awork(6) = awork(6)+one
        error = zero
        ratio_errors = zero
     else
! No duplicate check
     end if

     if (ratio_errors*error <= tiny_r_kind) muse(i)=.false.

     if (nobskeep>0.and.luse_obsdiag) call obsdiagNode_get(my_diag, jiter=nobskeep, muse=muse(i))

     val      = error*ddiff
     if(luse(i))then

!       Compute penalty terms (linear & nonlinear qc).
        val2     = val*val
        exp_arg  = -half*val2
        rat_err2 = ratio_errors**2
        if (cvar_pg(ikx) > tiny_r_kind .and. error >tiny_r_kind) then
           arg  = exp(exp_arg)
           wnotgross= one-cvar_pg(ikx)
           cg_ps=cvar_b(ikx)
           wgross = cg_term*cvar_pg(ikx)/(cg_ps*wnotgross)
           term =log((arg+wgross)/(one+wgross))
           wgt  = one-wgross/(arg+wgross)
           rwgt = wgt/wgtlim
        else
           term = exp_arg
           wgt  = wgtlim
           rwgt = wgt/wgtlim
        endif
        valqc = -two*rat_err2*term

        if (muse(i)) then
!          Accumulate statistics for obs used belonging to this task
           if(rwgt < one) awork(21) = awork(21)+one
           awork(4)=awork(4)+val2*rat_err2
           awork(5)=awork(5)+one
           awork(22)=awork(22)+valqc
           nn=1
        else

!          rejected obs
           nn=2
!          monitored obs
           if(ratio_errors*error >=tiny_r_kind)nn=3
        end if

!       Accumulate statistics for each ob type

        ress   = ddiff*r10
        ressw2 = ress*ress
        bwork(1,ikx,1,nn)  = bwork(1,ikx,1,nn)+one              ! count
        bwork(1,ikx,2,nn)  = bwork(1,ikx,2,nn)+ress             ! (o-g)
        bwork(1,ikx,3,nn)  = bwork(1,ikx,3,nn)+ressw2           ! (o-g)**2
        bwork(1,ikx,4,nn)  = bwork(1,ikx,4,nn)+val2*rat_err2    ! penalty
        bwork(1,ikx,5,nn)  = bwork(1,ikx,5,nn)+valqc            ! nonlin qc penalty

     end if

     if (luse_obsdiag) then
        call obsdiagNode_set(my_diag, wgtjo=(error*ratio_errors)**2, &
           jiter=jiter, muse=muse(i), nldepart=ddiff)
     endif

     if (.not. last .and. muse(i)) then

        allocate(my_head)
        call tcpNode_appendto(my_head,tcphead(ibin))

        my_head%idv = is
        my_head%iob = ioid(i)
        my_head%elat= data(ilate,i)
        my_head%elon= data(ilone,i)

        call get_ij(mm1,dlat,dlon,my_head%ij,my_head%wij)

        my_head%res      = ddiff
        my_head%err2     = error**2
        my_head%raterr2  = ratio_errors**2
        my_head%time     = dtime
        my_head%b        = cvar_b(ikx)
        my_head%pg       = cvar_pg(ikx)
        my_head%luse     = luse(i)
        if(oberror_tune) then
           my_head%kx    = ikx        ! data type for oberror tuning
           my_head%ppertb= data(iptrb,i)/error/ratio_errors ! obs perturbation
        endif

        if (luse_obsdiag) then
           call obsdiagNode_assert(my_diag, my_head%idv,my_head%iob,1, myname,'my_diag:my_head')
           my_head%diags => my_diag
        endif

        my_head => null()
     endif

! Save obs and simulated surface pressure data for diagnostic output

     if(conv_diagsave .and. luse(i))then
        ii=ii+1
        rstation_id     = data(id,i)
        pob      = pob*r10
        pges     = pges*r10
        pgesorig = pgesorig*r10
        err_input = data(ier,i)*r10   ! r10 converts cb to mb
        err_adjst = data(ier,i)*r10
        if (ratio_errors*error/r10>tiny_r_kind) then
           err_final = r10/(ratio_errors*error)
        else
           err_final = huge_single
        endif

        errinv_input = huge_single
        errinv_adjst = huge_single
        errinv_final = huge_single
        if (err_input>tiny_single) errinv_input = one/err_input
        if (err_adjst>tiny_single) errinv_adjst = one/err_adjst
        if (err_final>tiny_single) errinv_final = one/err_final

        if(binary_diag) call contents_binary_diag_(my_diag)
        if(netcdf_diag) call contents_netcdf_diag_(my_diag)

    end if ! conv_diagsave .true. and luse .true.

! End of loop over observations
  end do

! Release memory of local guess arrays
  call final_vars_

! Write information to diagnostic file
  if(conv_diagsave)then
     if(netcdf_diag) call nc_diag_write
     if(binary_diag .and. ii>0)then
        write(7)'tcp',nchar,nreal,ii,mype,idia0
        write(7)cdiagbuf(1:ii),rdiagbuf(:,1:ii)
        deallocate(cdiagbuf,rdiagbuf)
     end if
  end if

! End of routine
  return
  contains

  subroutine check_vars_ (proceed)
  logical,intent(inout) :: proceed
  integer(i_kind) ivar, istatus
! Check to see if required guess fields are available
  call gsi_metguess_get ('var::ps', ivar, istatus )
  proceed=ivar>0
  call gsi_metguess_get ('var::z' , ivar, istatus )
  proceed=proceed.and.ivar>0
  call gsi_metguess_get ('var::tv', ivar, istatus )
  proceed=proceed.and.ivar>0
  end subroutine check_vars_

  subroutine init_vars_

  real(r_kind),dimension(:,:  ),pointer:: rank2=>NULL()
  real(r_kind),dimension(:,:,:),pointer:: rank3=>NULL()
  character(len=5) :: varname
  integer(i_kind) ifld, istatus

! If require guess vars available, extract from bundle ...
  if(size(gsi_metguess_bundle)==nfldsig) then
!    get ps ...
     varname='ps'
     call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
     if (istatus==0) then
         if(allocated(ges_ps))then
            write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
            call stop2(999)
         endif
         allocate(ges_ps(size(rank2,1),size(rank2,2),nfldsig))
         ges_ps(:,:,1)=rank2
         do ifld=2,nfldsig
            call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus)
            ges_ps(:,:,ifld)=rank2
         enddo
     else
         write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
         call stop2(999)
     endif
!    get z ...
     varname='z'
     call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank2,istatus)
     if (istatus==0) then
         if(allocated(ges_z))then
            write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
            call stop2(999)
         endif
         allocate(ges_z(size(rank2,1),size(rank2,2),nfldsig))
         ges_z(:,:,1)=rank2
         do ifld=2,nfldsig
            call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank2,istatus)
            ges_z(:,:,ifld)=rank2
         enddo
     else
         write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
         call stop2(999)
     endif
!    get tv ...
     varname='tv'
     call gsi_bundlegetpointer(gsi_metguess_bundle(1),trim(varname),rank3,istatus)
     if (istatus==0) then
         if(allocated(ges_tv))then
            write(6,*) trim(myname), ': ', trim(varname), ' already incorrectly alloc '
            call stop2(999)
         endif
         allocate(ges_tv(size(rank3,1),size(rank3,2),size(rank3,3),nfldsig))
         ges_tv(:,:,:,1)=rank3
         do ifld=2,nfldsig
            call gsi_bundlegetpointer(gsi_metguess_bundle(ifld),trim(varname),rank3,istatus)
            ges_tv(:,:,:,ifld)=rank3
         enddo
     else
         write(6,*) trim(myname),': ', trim(varname), ' not found in met bundle, ier= ',istatus
         call stop2(999)
     endif
  else
     write(6,*) trim(myname), ': inconsistent vector sizes (nfldsig,size(metguess_bundle) ',&
                 nfldsig,size(gsi_metguess_bundle)
     call stop2(999)
  endif
  end subroutine init_vars_

  subroutine init_netcdf_diag_
  character(len=80) string
  character(len=128) diag_conv_file
  integer(i_kind) ncd_fileid,ncd_nobs
  logical append_diag
  logical,parameter::verbose=.false.
     write(string,900) jiter
900  format('conv_tcp_',i2.2,'.nc4')
     diag_conv_file=trim(dirname) // trim(string)

     inquire(file=diag_conv_file, exist=append_diag)

     if (append_diag) then
        call nc_diag_read_init(diag_conv_file,ncd_fileid)
        ncd_nobs = nc_diag_read_get_dim(ncd_fileid,'nobs')
        call nc_diag_read_close(diag_conv_file)

        if (ncd_nobs > 0) then
           if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists.  Appending.  nobs,mype=',ncd_nobs,mype
        else
           if(verbose) print *,'file ' // trim(diag_conv_file) // ' exists but contains no obs.  Not appending. nobs,mype=',ncd_nobs,mype
           append_diag = .false. ! if there are no obs in existing file, then do not try to append
        endif
     end if
     call nc_diag_init(diag_conv_file, append=append_diag)

     if (.not. append_diag) then ! don't write headers on append - the module will break?
        call nc_diag_header("date_time",ianldate )
        call nc_diag_header("Number_of_state_vars", nsdim          )
     endif
  end subroutine init_netcdf_diag_
  subroutine contents_binary_diag_(odiag)
  type(obs_diag),pointer,intent(in):: odiag
        cdiagbuf(ii)    = station_id         ! station id
        rdiagbuf(1,ii)  = ictype(ikx)        ! observation type
        rdiagbuf(2,ii)  = icsubtype(ikx)     ! observation subtype
        rdiagbuf(3,ii)  = data(ilate,i)      ! observation latitude (degrees)
        rdiagbuf(4,ii)  = data(ilone,i)      ! observation longitude (degrees)
        rdiagbuf(5,ii)  = 0                  ! station elevation (meters)
        rdiagbuf(6,ii)  = data(ipres,i)*r10  ! observation pressure (hPa)
        rdiagbuf(7,ii)  = 0                  ! observation height (meters)
        rdiagbuf(8,ii)  = dtime-time_offset  ! obs time (hours relative to analysis time)

        rdiagbuf(9,ii)  = 1                  ! input prepbufr qc or event mark
        rdiagbuf(10,ii) = rmiss_single       ! setup qc or event mark
        rdiagbuf(11,ii) = 1                  ! read_prepbufr data usage flag
        if(muse(i)) then
           rdiagbuf(12,ii) = one             ! analysis usage flag (1=use, -1=not used)
        else
           rdiagbuf(12,ii) = -one
        endif

        rdiagbuf(13,ii) = rwgt               ! nonlinear qc relative weight
        rdiagbuf(14,ii) = errinv_input       ! prepbufr inverse obs error (hPa**-1)
        rdiagbuf(15,ii) = errinv_adjst       ! read_prepbufr inverse obs error (hPa**-1)
        rdiagbuf(16,ii) = errinv_final       ! final inverse observation error (hPa**-1)

        rdiagbuf(17,ii) = pob                ! surface pressure observation (hPa)
        rdiagbuf(18,ii) = pob-pges           ! obs-ges used in analysis (coverted to hPa)
        rdiagbuf(19,ii) = pob-pgesorig       ! obs-ges w/o adjustment to guess surface pressure (hPa)
        rdiagbuf(20,ii) = 1.e+10_r_single    ! spread (filled in by EnKF)

        idia=idia0
        if (lobsdiagsave) then
           do jj=1,miter
              idia=idia+1
              if (odiag%muse(jj)) then
                 rdiagbuf(idia,ii) = one
              else
                 rdiagbuf(idia,ii) = -one
              endif
           enddo
           do jj=1,miter+1
              idia=idia+1
              rdiagbuf(idia,ii) = odiag%nldepart(jj)
           enddo
           do jj=1,miter
              idia=idia+1
              rdiagbuf(idia,ii) = odiag%tldepart(jj)
           enddo
           do jj=1,miter
              idia=idia+1
              rdiagbuf(idia,ii) = odiag%obssen(jj)
           enddo
        endif
        if (save_jacobian) then
           call writearray(dhx_dx, rdiagbuf(idia+1:nreal,ii))
           idia = idia + size(dhx_dx)
        endif

  end subroutine contents_binary_diag_
  subroutine contents_netcdf_diag_(odiag)
  type(obs_diag),pointer,intent(in):: odiag
! Observation class
  character(7),parameter     :: obsclass = '    tcp'
  real(r_kind),dimension(miter) :: obsdiag_iuse
           call nc_diag_metadata("Station_ID",              station_id             )
           call nc_diag_metadata("Observation_Class",       obsclass               )
           call nc_diag_metadata("Observation_Type",        ictype(ikx)            )
           call nc_diag_metadata("Observation_Subtype",     icsubtype(ikx)         )
           call nc_diag_metadata("Latitude",                sngl(data(ilate,i))    )
           call nc_diag_metadata("Longitude",               sngl(data(ilone,i))    )
           call nc_diag_metadata("Station_Elevation",       sngl(zero)             )
           call nc_diag_metadata("Pressure",                sngl(data(ipres,i)*r1000))
           call nc_diag_metadata("Height",                  sngl(zero)             )
           call nc_diag_metadata("Time",                    sngl(dtime-time_offset))
           call nc_diag_metadata("Prep_QC_Mark",            sngl(one)              )
           call nc_diag_metadata("Prep_Use_Flag",           sngl(one)              )
           call nc_diag_metadata("Nonlinear_QC_Rel_Wgt",    sngl(rwgt)             )
           if(muse(i)) then
              call nc_diag_metadata("Analysis_Use_Flag",    sngl(one)              )
           else
              call nc_diag_metadata("Analysis_Use_Flag",    sngl(-one)             )
           endif

           call nc_diag_metadata("Errinv_Input",            sngl(errinv_input)     )
           call nc_diag_metadata("Errinv_Adjust",           sngl(errinv_adjst)     )
           call nc_diag_metadata("Errinv_Final",            sngl(errinv_final)     )

           call nc_diag_metadata("Observation",                   sngl(pob)        )
           call nc_diag_metadata("Obs_Minus_Forecast_adjusted",   sngl(pob-pges)   )
           call nc_diag_metadata("Obs_Minus_Forecast_unadjusted", sngl(pob-pgesorig))

           if (lobsdiagsave) then
              do jj=1,miter
                 if (odiag%muse(jj)) then
                       obsdiag_iuse(jj) =  one
                 else
                       obsdiag_iuse(jj) = -one
                 endif
              enddo

              call nc_diag_data2d("ObsDiagSave_iuse",     obsdiag_iuse                             )
              call nc_diag_data2d("ObsDiagSave_nldepart", odiag%nldepart )
              call nc_diag_data2d("ObsDiagSave_tldepart", odiag%tldepart )
              call nc_diag_data2d("ObsDiagSave_obssen",   odiag%obssen   )
           endif

          if (save_jacobian) then
              call fullarray(dhx_dx, dhx_dx_array)
              call nc_diag_data2d("Observation_Operator_Jacobian", dhx_dx_array)
          endif

           call nc_diag_data2d("virtual_temperature", tvges)

           call nc_diag_metadata("surface_air_pressure", psges )
           call nc_diag_metadata("surface_geopotential_height", zsges )

  end subroutine contents_netcdf_diag_

  subroutine final_vars_
    if(allocated(ges_tv)) deallocate(ges_tv)
    if(allocated(ges_z )) deallocate(ges_z )
    if(allocated(ges_ps)) deallocate(ges_ps)
  end subroutine final_vars_

end subroutine setuptcp
end module tcp_setup


      SUBROUTINE VECPRT (A,NUMM)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION  A(*)
      COMMON /MOLKST/ NUMAT,NAT(NUMATM),NFIRST(NUMATM),NMIDLE(NUMATM),
     1                NLAST(NUMATM), NORBS, NELECS,NALPHA,NBETA,
     2                NCLOSE,NOPEN,NDUMY,FRACT
      COMMON /ELEMTS/ ELEMNT(107)
C**********************************************************************
C
C  VECPRT PRINTS A LOWER-HALF TRIANGLE OF A SQUARE MATRIX, THE
C         LOWER-HALF TRIANGLE BEING STORED IN PACKED FORM IN THE
C         ARRAY "A"
C
C ON INPUT:
C      A      = ARRAY TO BE PRINTED
C      NUMM   = SIZE OF ARRAY TO BE PRINTED
C(REF) NUMAT  = NUMBER OF ATOMS IN THE MOLECULE (THIS IS NEEDED TO
C               DECIDE IF AN ATOMIC ARRAY OR ATOMIC ORBITAL ARRAY IS
C               TO BE PRINTED
C(REF) NAT    = LIST OF ATOMIC NUMBERS
C(REF) NFIRST = LIST OF ORBITAL COUNTERS
C(REF) NLAST  = LIST OF ORBITAL COUNTERS
C
C  NONE OF THE ARGUMENTS ARE ALTERED BY THE CALL OF VECPRT
C
C*********************************************************************
      DIMENSION NATOM(MAXORB)
      CHARACTER * 6 LINE(21)
      CHARACTER*2 ELEMNT,ATORBS(9), ITEXT(MAXORB), JTEXT(MAXORB)
      DATA ATORBS/' S','PX','PY','PZ','X2','XZ','Z2','YZ','XY'/
      IF(NUMAT.NE.0.AND.NUMAT.EQ.NUMM) THEN
C
C    PRINT OVER ATOM COUNT
C
         DO 10 I=1,NUMAT
            ITEXT(I)='  '
            JTEXT(I)=ELEMNT(NAT(I))
            NATOM(I)=I
   10    CONTINUE
      ELSE
         IF (NUMAT.NE.0.AND.NLAST(NUMAT) .EQ. NUMM) THEN
            DO 30 I=1,NUMAT
               JLO=NFIRST(I)
               JHI=NLAST(I)
               L=NAT(I)
               K=0
               DO 20 J=JLO,JHI
                  K=K+1
                  ITEXT(J)=ATORBS(K)
                  JTEXT(J)=ELEMNT(L)
                  NATOM(J)=I
   20          CONTINUE
   30       CONTINUE
         ELSE
            NUMB=ABS(NUMM)
            DO 40 I=1,NUMB
               ITEXT(I) = '  '
               JTEXT(I) = '  '
   40       NATOM(I)=I
         ENDIF
      ENDIF
      NUMB=ABS(NUMM)
      DO 50 I=1,21
   50 LINE(I)='------'
      LIMIT=(NUMB*(NUMB+1))/2
      KK=8
      NA=1
   60 LL=0
      M=MIN0((NUMB+1-NA),6)
      MA=2*M+1
      M=NA+M-1
      WRITE(6,100)(ITEXT(I),JTEXT(I),NATOM(I),I=NA,M)
      WRITE (6,110) (LINE(K),K=1,MA)
      DO 80 I=NA,NUMB
         LL=LL+1
         K=(I*(I-1))/2
         L=MIN0((K+M),(K+I))
         K=K+NA
         IF ((KK+LL).LE.50) GO TO 70
         WRITE (6,120)
         WRITE (6,100) (ITEXT(N),JTEXT(N),NATOM(N),N=NA,M)
         WRITE (6,110) (LINE(N),N=1,MA)
         KK=4
         LL=0
   70    WRITE (6,130) ITEXT(I),JTEXT(I),NATOM(I),(A(N),N=K,L)
   80 CONTINUE
      IF (L.GE.LIMIT) GO TO 90
      KK=KK+LL+4
      NA=M+1
      IF ((KK+NUMB+1-NA).LE.50) GO TO 60
      KK=4
      WRITE (6,120)
      GO TO 60
   90 RETURN
C
  100 FORMAT (1H0/13X,10(1X,A2,1X,A2,I3,2X))
  110 FORMAT (1H ,21A6)
  120 FORMAT (1H1)
  130 FORMAT (1H ,A2,1X,A2,I5,10F11.6)
C
      END


c $Id: init.f,v 1.22 2007/01/30 14:50:25 bleicher Exp $
C####C##1#########2#########3#########4#########5#########6#########7##
      subroutine uinit(io)
c
c Revision : 1.0
c
cinput io : flag for call to {\tt input(io)}
c
c This subroutine calls initialization procedures for uqmd
c i.e. random generater, etc.
c Routines called before the first (physical) event of uqmd should
c enter here. an exception is the subroutine {\tt init}. {\tt init} should NOT
c be included in uinit.
cccccCcc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc
      implicit none
      include 'coms.f'
      include 'options.f'
      include 'boxinc.f'
      include 'inputs.f'
      integer io

      call set0
      call params

c.. display logo
      call urqmdlogo

c read input file
      call input(io)

      call strini

      call output(19)

      firstseed=.true.
      fixedseed=ranseed.gt.0
      if(fixedseed)write(6,*)'fixed random number:',ranseed
      call sseed(ranseed)
      call loginit
      if(CTOption(33).eq.0.or.CTOption(9).eq.0) call loadwtab(io)
c in case of CASCADE mode, the potentials need not be calculated
      if(EoS.ne.0) then
         if(logSky) call potdww
         if(logYuk) call potYuk
         if(logPau) call potPau
         if(logCb)  call potCb
      endif
c
c  calculate the normalization of resonances distribution...
c
      call norm_init

      if(io.ne.0) return

c     do not initialize projectile and target if old event is read in
      if(CTOption(40).ne.0) return
c SEH: in urqlnk in corsika
      if(boxflag.eq.0) then
c
c initialize nuclei (projectile and target) and store them
c
c initialize normal projectile
         if(prspflg.eq.0) then
c         if(eos.eq.0) then
            call cascinit(Zp,Ap,1)
c         else
c            write(6,*)'illegal EOS in init.'
c            stop 137
c         endif
         endif
c initialize normal target
         if(At.ne.0) then
            if(trspflg.eq.0) then
c            if(eos.eq.0) then
               call cascinit(Zt,At,2)
c            else
c               write(6,*)'illegal EOS in init.'
c               stop 137
c            endif
            endif
         endif
      endif

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine init
c
c     Revision : 1.0
c     This subroutine calls initialization procedures for different
c     equations of state and calculation modi.

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none
      include 'coms.f'
      include 'options.f'
      include 'comres.f'
      include 'inputs.f'
      include 'freezeout.f'
      include 'newpart.f'
      include 'boxinc.f'
      include 'colltab.f'

      integer j,k,icount,npold,getspin,fchg,indsp(2),isrt,ipbm
      real*8 nucrad,dstt,dstp,pcm,eb,embeam,emtarget
      real*8 massit,ranf,pcms,dectim
      real*8 gaeq,beeq,galab,belab,ppeq,pteq
      real*8 pboost
      real*8 ratio
      integer AAp, AAt
        integer nnuc
        parameter (nnuc=11)
        save isrt,ipbm
        logical bcorr
        common /ini/ bcorr

        integer i,flagy
        real*8 alf,regula
c momenta
       real*8 mx,my,mz
c important: never change!
      npart = 0
      npold = 0
      nbar=0
      nmes=0
      apt=0
      uid_cnt=0
c reset counters
c     all collisions/decays
      ctag  = 0
c     all decays
      dectag = 0
c     number of prod. hard resonances
      NHardRes=0
c     number of prod. soft resonances
      NSoftRes=0
c     number of prod. resonances via decay
      NDecRes=0
c     number of blocked collisions
      NBlColl=0
c     number of elastic collisions
      NElColl=0
c
      eb=0D0
c icount is the number of EXTRAordinary pro/tar combinations (i.e. pion ...)
      icount = 0
c reset particle vectors
      do 20 j=1,nmax
        spin(j)  = 0
        ncoll(j) = 0
        lstcoll(j)=0
        r0(j) = 0.0
        rx(j)    = 0.0
        ry(j)    = 0.0
        rz(j)    = 0.0
        p0(j)    = 0.0
        px(j)    = 0.0
        py(j)    = 0.0
        pz(j)    = 0.0
        frr0(j) = 0.0
        frrx(j)    = 0.0
        frry(j)    = 0.0
        frrz(j)    = 0.0
        frp0(j)    = 0.0
        frpx(j)    = 0.0
        frpy(j)    = 0.0
        frpz(j)    = 0.0
        fmass(j) = 0.0
        charge(j)= 0
        iso3(j)  = 0
        ityp(j)  = 0
        dectime(j)= 0.0
        origin(j)=0
        tform(j)=0.0
        xtotfac(j)=1.0
        uid(j)=0
         ffermpx(j) = 0.0
         ffermpy(j) = 0.0
         ffermpz(j) = 0.0
ctd
         do 21 k=1,2
            p0td(k,j)=0.d0
            pxtd(k,j)=0.d0
            pytd(k,j)=0.d0
            pztd(k,j)=0.d0
            fmasstd(k,j)=0.d0
            ityptd(k,j)=0
            iso3td(k,j)=0
 21      continue
 20   continue

      if(CTOption(40).ne.0) then
         call getoldevent
         return
      endif

      if (boxflag.eq.1) then
         mbpx=0
         mbpy=0
         mbpz=0
         mx=0
         my=0
         mz=0

         nbar=0
         nmes=0
         flagy=edensflag
         ctoption(30)=0         ! no frozen fermi for box
         do 100 cbox=1,mbox
            if (flagy.ge.1) then
               bptpmax(cbox)=edens/mbox
            endif
            call bptinit(cbox)
 100     Continue

c prevents a collective motion in the box
         do 143 i=1,npart
            mbpx=mbpx+px(i)
            mbpy=mbpy+py(i)
            mbpz=mbpz+pz(i)
 143     continue
         do 142 i=1,npart
            px(i)=px(i)-mbpx/npart
            py(i)=py(i)-mbpy/npart
            pz(i)=pz(i)-mbpz/npart
            call setonshell(i)
 142     continue

         if (flagy.ge.1) then
            alf=Regula(edens)
            do 42  i=1,npart
               px(i) = alf*px(i)
               py(i) = alf*py(i)
               pz(i) = alf*pz(i)
               call setonshell(i)
 42         continue
         endif
         Write(*,*) 'walls selected'
         mbflag=2
         if (solid.gt.0) Write(*,*)'solid walls selected'

         Return
      EndIf

      if(At.ne.0) then
         if (CTParam(21).eq.0.0) then
            dstp = nucrad(Ap)+CTParam(41)
            dstt = nucrad(At)+CTParam(41)
         else
            ratio = sqrt((1 + 4.0*CTParam(21)/3.0) /
     $           (1 - 2.0*CTParam(21)/3.0) )
            dstp = nucrad(Ap)*ratio**(2.0/3.0)+CTParam(41)
            dstt = nucrad(At)*ratio**(2.0/3.0)+CTParam(41)
         endif
c add radius offset
         dstp=dstp+CTParam(30)
         dstt=dstt+CTParam(30)
c
c         dst=0.5d0*(dstt+dstp)
      else
c            dst=0.d0
            dstp=0d0
            dstt=0d0
      endif

ce For anti nuclei:
      AAp = abs(Ap)
      AAt = abs(At)

c
c fix masses of projectile and target for calculation of pbeam,ecm,pcm
      if(prspflg.eq.0) then
         embeam=AAp*EMNUC
      elseif(prspflg.eq.1) then
         icount=icount+1
c!!!  sofar only pro/tar with fixed masses allowed
         embeam=massit(spityp(1))
      endif
      if(trspflg.eq.0) then
         emtarget=AAt*EMNUC
      elseif(trspflg.eq.1) then
         icount=icount+1
         emtarget=massit(spityp(2))
      endif
c
c p(equal_speed) with given elab  cccccccccccccccccccccccccccccccccccccc

      if(srtflag.eq.0) then

         ebeam=AAp*ebeam
         eb=ebeam+embeam
         pbeam=sqrt(ebeam*(ebeam+2.0d0*embeam))

c     p(equal_speed) with given sqrt(s) ccccccccccccccccccccccccccccccccccccc

      elseif(srtflag.eq.1) then

c     in this mode, everything has to calculated on a per particle basis
         embeam=embeam/dble(AAp)
         emtarget=emtarget/dble(AAt)

         if(emtarget+embeam.gt.srtmin)then
            srtmin=emtarget+embeam+1d-2
            write(6,*)' *** error:initial energy below treshold'
            write(6,*)'     c.m. energy will be increased to:',
     &           srtmin
            srtmax=max(srtmax,srtmin)
         end if
         if(efuncflag.eq.0) then
            ecm=srtmin
         else                   ! if(efuncflag.eq.1) then
c     excitation function
            if(mod((event-1)*nsrt,nevents).eq.0
     &           .and.firstev.gt.0)then
               if(efuncflag.eq.1)then
                  ecm=ecm+(srtmax-srtmin)/dble(nsrt-1)
               else if(efuncflag.eq.2)then
                  isrt=isrt+1
                  ecm=srtmin*exp(
     &                 (dlog(srtmax/srtmin))
     &                 *isrt/(nsrt-1))
               end if
            elseif(firstev.eq.0) then
               isrt=0
               firstev=1
               ecm=srtmin
            endif
         endif
c
c     this is all on a per particle basis
         pcm=pcms(ecm,embeam,emtarget)
         ebeam=sqrt(embeam**2 + (pcm*ecm/emtarget)**2) - embeam
         pbeam=pcm*ecm/emtarget
c     now revert to full quantities
         ebeam=AAp*ebeam
         pbeam=AAp*pbeam
         embeam=embeam*AAp
         emtarget=emtarget*AAt
         eb=sqrt(embeam**2+pbeam**2)

c     p(equal_speed) with given plab ccccccccccccccccccccccccccccccccccc
      elseif(srtflag.eq.2) then
         if(efuncflag.gt.0) then
c     excitation function
c     calculate the next pbeam if number of events at current pbeam exceeds nevents/npb
            if (mod((event-1)*npb,nevents).eq.0
     &           .and.firstev.gt.0) then
c     excitation function linear in pbeam
               if (efuncflag.eq.1) then
                  pbeam=pbeam+(pbmax-pbmin)/dble(npb-1)
c     else use a logaritmic excitation function
               else if(efuncflag.eq.2) then
                  ipbm=ipbm+1
                  pbeam=pbmin*exp(
     &                 (dlog(pbmax/pbmin))
     &                 *ipbm/(npb-1))
               end if
            else if (firstev.eq.0) then
               ipbm=0
               firstev=1
               pbeam=pbmin
            endif
         endif
c     input was pbeam per particle
         pbeam=AAp*pbeam
         eb=sqrt(embeam**2+pbeam**2)
         ebeam=eb-embeam
      endif

c     now do the calculation of equal_speed quantities
      galab=eb/embeam           ! gamma_lab
      belab=pbeam/eb            ! beta_lab
      gaeq=sqrt(0.5*(1+galab))
      beeq=belab*galab/(1+galab)
      ppeq=gaeq*beeq*embeam     ! p_projectile(eq)
      pteq=-(gaeq*beeq*emtarget)

c     reduce to per particle quantities
      ppeq=ppeq/dble(AAp)
      if(AAt.ne.0) then
         pteq=pteq/dble(AAt)
         emtarget=emtarget/dble(AAt)
      endif
      embeam=embeam/dble(AAp)
      pbeam=pbeam/dble(AAp)
      ebeam=ebeam/dble(AAp)
c     the following is the NN sqrt(s)
      ecm=sqrt(embeam**2+2*eb/dble(AAp)*emtarget+emtarget**2)
ccccccccccccccccccccccccccccccccccccccccccccc
c compute transformation betas for output

         pcm=max(1d-10,pbeam*emtarget/ecm)

         if(CTOption(27).eq.0) then
            betann=0.d0
            betatar=pcm/sqrt(pcm**2+emtarget**2)
            betapro=-(1.*pcm/sqrt(pcm**2+embeam**2))
         elseif(CTOption(27).eq.1) then
            betann=-(1*pcm/sqrt(pcm**2+emtarget**2))
            betatar=0.d0
            betapro=-(1*pbeam/sqrt(pbeam**2+embeam**2))
         elseif(CTOption(27).eq.2) then
            betann=pcm/sqrt(pcm**2+emtarget**2)
            betatar=pbeam/sqrt(pbeam**2+embeam**2)
            betapro=0.d0
         endif

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c determine impact parameter
         if(CTOption(5).eq.0) then
            bimp=bdist
         elseif(CTOption(5).eq.1) then
            if(bdist.gt.(nucrad(Ap)+nucrad(At)+2*CTParam(30)))
     &           bdist=nucrad(Ap)+nucrad(At)+2*CTParam(30)
            bimp=sqrt(bmin**2 + ranf(0) * (bdist**2 - bmin**2))
         elseif(CTOption(5).eq.2) then
            if(bdist.gt.(nucrad(Ap)+nucrad(At)+2*CTParam(30)))
     &           bdist=nucrad(Ap)+nucrad(At)+2*CTParam(30)
            bimp=bmin+ranf(0)*(bdist-bmin)
         else
            write(6,*)'illegal CTOption(5) :',CTOption(5)
            stop 137
         endif

         if(At.eq.0) bimp=0.d0

c initialize normal projectile
         if(prspflg.eq.0) then
            if(mod(event,nnuc).eq.0)then
               call cascinit(Zp,Ap,1)
            endif
            call getnucleus(1,npart)
            npart=npart+AAp
c change reference frame
            if (CTOption(27).eq.1) then
               pboost = -pbeam
            elseif (CTOption(27).eq.2) then
               pboost = 0.d0
            else
               pboost = -ppeq
            endif
            call boostnuc(npold+1,npold+AAp,
     &                    pboost,0.5*bimp,-dstp)
c save fermi motion
            if (CTOption(30).eq.1) then
               call savefermi(npold+1,npold+AAp,-pboost)
            endif
            npold=npart
            nbar=nbar+AAp
            if (CTParam(20).ne.0) then
               call getnucleus(1,npart)
               npart=npart+AAp
               call boostnuc(npold+1,npold+AAp,
     &              pboost,0.5*bimp,-dstp+CTParam(20))
               if (CTOption(30).eq.1) then
                  call savefermi(npold+1,npold+AAp,-pboost)
               endif
               npold=npart
               nbar=nbar+AAp
            endif
         endif

c initialize normal target
         if(At.ne.0) then
            if(trspflg.eq.0) then
               if(mod(event,nnuc).eq.0)then
                  call cascinit(Zt,At,2)
               endif
               call getnucleus(2,npart)
               npart=npart+AAt
c change ref. frame
               if(CTOption(27).eq.1) then
                  pboost = 0.d0
               elseif(CTOption(27).eq.2) then
                  pboost = pbeam
               else
                  pboost = -pteq
               endif
               call boostnuc(npold+1,npold+AAt,
     &                       pboost,-(0.5*bimp),dstt)
c save fermi motion
               if (CTOption(30).eq.1) then
                  call savefermi(npold+1,npold+AAt,-pboost)
               endif
               npold=npart
               nbar = nbar + AAt
            endif
         endif

c set unique ID-tag counter (is not initialized with getnucleus calls)
         uid_cnt=npart

         if(icount.eq.0) then
c set counter for collupd
            apt=Ap
            return
c initialize special PRO/TAR combinations
         elseif(icount.eq.1) then
            if(prspflg.eq.1) then
               indsp(1)=1
c the "regular" target sits first in the arrays
               apt=At
            else
               indsp(1)=2
               apt=Ap
            endif
         elseif(icount.eq.2) then
            if(abs(spityp(1)).le.abs(spityp(2))) then
               indsp(1)=1
               indsp(2)=2
               apt=Ap
            else
               indsp(1)=2
               indsp(2)=1
               apt=At
            endif
         endif
         do 40 j=1,icount
            npart=npart+1
            if(abs(spityp(indsp(j))).lt.minmes) then
               nbar=nbar+1
            else
               nmes=nmes+1
            endif
            iso3(npart) = spiso3(indsp(j))
            ityp(npart) = spityp(indsp(j))
            uid_cnt=uid_cnt+1
            uid(npart)=uid_cnt
            spin(npart) = getspin(ityp(npart),-1)
            charge(npart)=fchg(iso3(npart),ityp(npart))
            fmass(npart) = massit(ityp(npart))
            rx(npart) = 0.d0
            ry(npart) = 0.d0
            rz(npart) = 0.d0
            px(npart) = 0.d0
            py(npart) = 0.d0
c       pz ist stored in pbeam,p?eq!
            pz(npart) = 0.d0
            p0(npart)=sqrt(px(npart)**2+py(npart)**2+pz(npart)**2
     &           +fmass(npart)**2)
            if(indsp(j).eq.1) then
               if(CTOption(27).eq.1) then
                  call boostnuc(npart,npart,-pbeam,0.5*bimp,-dstp)
               elseif(CTOption(27).eq.2) then
                  call boostnuc(npart,npart,0.d0,0.5*bimp,-dstp)
               else
                  call boostnuc(npart,npart,-ppeq,0.5*bimp,-dstp)
               endif
            elseif(indsp(j).eq.2) then
               if(CTOption(27).eq.1) then
                  call boostnuc(npart,npart,0.d0,-(0.5*bimp),dstt)
               elseif(CTOption(27).eq.2) then
                  call boostnuc(npart,npart,pbeam,-(0.5*bimp),dstt)
               else
                  call boostnuc(npart,npart,-pteq,-(0.5*bimp),dstt)
               endif
            endif
            dectime(npart) = dectim(npart,1)

 40      continue
      return
      end

      subroutine savefermi(i1,i2,p)
c
c     Revision : 1.0
c     Store fermi momentum in fferm
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none
      include 'coms.f'

      integer i,i1,i2
      real*8 p

      if (i1.eq.0) return

      if (ncoll(i1).gt.0) return

      do i=i1,i2
         ffermpx(i)=px(i)
         ffermpy(i)=py(i)
         ffermpz(i)=pz(i)-p
         px(i)=0.0
         py(i)=0.0
         pz(i)=p
      enddo

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine addfermi(ind,p)
c
c     Revision : 1.0
c     Restore fermi momentum from fferm
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc

      implicit none
      include 'coms.f'

      integer ind
      real*8 p

      if (ind.eq.0) return

      p = pz(ind)
      px(ind) = px(ind)+ffermpx(ind)
      py(ind) = py(ind)+ffermpy(ind)
      pz(ind) = pz(ind)+ffermpz(ind)
      ffermpx(ind) = 0.0
      ffermpy(ind) = 0.0
      ffermpz(ind) = 0.0

      return
      end