      subroutine families

      use fractdata
      implicit double precision(a-h,o-z)

      integer, allocatable   :: ngp(:),kgroup(:),numchgs(:),natchg(:,:)
      integer, allocatable   :: formal(:)
      integer, allocatable   :: numatoms(:),numelects(:)

      dimension xcap(24,3),xmean(3)
      dimension nattach(24)

c assumes no more than 10 formal charges in a group

      character*1 I0(0:10),ca1,ca2,ca3,ca4
      character*16 ca
      character*17 da
      character*22 ea,fa,pa,panames(10000)
      character*27 ga

      integer, allocatable   ::nchgatoms(:)

      allocate(ngp(natomall))
      allocate(kgroup(natomall))
      allocate(numatoms(natomall))
      allocate(numelects(natomall))
      allocate(numchgs(natomall))
      allocate(natchg(natomall,maxfamily))
      allocate(formal(natomall))

      formal=0

      bohr=1.8897259886d0

      I0(10)='0'
      I0(0)='0'
      I0(1)='1'
      I0(2)='2'
      I0(3)='3'
      I0(4)='4'
      I0(5)='5'
      I0(6)='6'
      I0(7)='7'
      I0(8)='8'
      I0(9)='9'

c read in which atoms are "formally" charged
      open(unit=1,file='IN_CHARGES',status='old')
      read(1,*)
      read(1,*)numcharges
      if(numcharges.eq.0)go to 601
      allocate(nchgatoms(numcharges))
      read(1,*)
      do n=1,numcharges
       read(1,*)nchgatoms(n)
      enddo
601   continue
      close(unit=1)

c  this sub outputs the atoms in each family.
c  these are needed by findHbond and findHandCbond to
c  avoid connecting families multiple times by "-1" bonds

#ifdef __GFORTRAN__
      open(unit=20,file='families.out',status='unknown')
#else
      open(unit=20,file='families.out',status='unknown',buffered='YES')
#endif

      write(20,*)' The number of groups'
      write(20,*)natom
      write(20,*)' The number of atoms in each group & their identities'
      do n=1,natom
      write(20,*)nfam(n)
      write(20,*)(ifam(n,i),i=1,nfam(n))
      enddo

      close(unit=20)

c evaluate group number
      do n=1,natom
       do i=1,nfam(n)
        ngp(ifam(n,i))=n
       enddo
      enddo

      do n=1,natomall
       write(84,*)n,ngp(n)
      enddo

c if Level = 0 and formal charges exist, ".chg" are created for use
c as background charges

      if(Level.eq.0)then

c check to see if any groups are charged
      match=0
      do n=1,natom
      do i=1,nfam(n)
      if(iabs(ichg(ifam(n,i))).gt.0)then
       match=1
       formal(n)=1
      endif

c extra code to account for atoms in IN_CHARGES
      if(numcharges.gt.0)then
       do j=1,numcharges
        if(ifam(n,i).eq.nchgatoms(j))then
         match=1
         formal(n)=1
        endif
       enddo
      endif

      enddo
      enddo

c allow all groups to have npa charges calculated
c     match=1

      if(match.eq.1)then
#ifdef __GFORTRAN__
       open(unit=90,file='CHARGECOORDS',status='unknown')
#else
       open(unit=90,file='CHARGECOORDS',status='unknown',buffered='YES')
#endif
      endif

c keep count of the number of groups containing formal charges
      kcharge=0

      do n=1,natom

       nsum=0
       nchg=0
       name1=0
       do i=1,nfam(n)
       nsum=nsum+ichg(ifam(n,i))
       nchg=nchg+iabs(ichg(ifam(n,i)))

c extra code to account for atoms in IN_CHARGES
       if(numcharges.gt.0)then
        do j=1,numcharges
         if(ifam(n,i).eq.nchgatoms(j))nchg=nchg+1
        enddo
       endif

       if(iabs(ichg(ifam(n,i))).gt.0)name1=ifam(n,i)
       enddo

       if(name1.eq.0)name1=ifam(n,1)

c allow all groups to have npa charges calculated
c      nchg=1

c temp skip to create "charge" files for every group"
c       if(iabs(nsum).gt.0)then

         if(nchg.gt.0)then

c as of 060613, use the group number in the name of the file
         name1=n

         kcharge=kcharge+1
         kgroup(kcharge)=n
         ncount=0
         do i=1,nfam(n)
          if(iabs(ichg(ifam(n,i))).gt.0)then
           ncount=ncount+1
           natchg(kcharge,ncount)=ifam(n,i)
          endif
         enddo
         numchgs(kcharge)=ncount

c find caps as these must be added to get the mean group position
       numbercaps=0
       do j=1,3
        xmean(j)=0.d0
       enddo
       do i=1,nfam(n)
        do m=1,nbondso
         if(mbstore(m).eq.ifam(n,i))then
          if(ngp(nbstore(m)).ne.n.and.multstore(m).gt.0)then
            sum1=0.23d0+radius(mbstore(m))
            sum2=radius(mbstore(m))+radius(nbstore(m))
            fact1=sum1/sum2
            numbercaps=numbercaps+1
            do j=1,3
            xmean(j)=xmean(j)+c(mbstore(m),j)
     .      +fact1*(c(nbstore(m),j)-c(mbstore(m),j))
            xcap(numbercaps,j)=c(mbstore(m),j)
     .      +fact1*(c(nbstore(m),j)-c(mbstore(m),j))
            enddo
            nattach(numbercaps)=mbstore(m)
          endif
         endif
         if(nbstore(m).eq.ifam(n,i))then
          if(ngp(mbstore(m)).ne.n.and.multstore(m).gt.0)then
            sum1=0.23d0+radius(nbstore(m))
            sum2=radius(mbstore(m))+radius(nbstore(m))
            fact1=sum1/sum2
            numbercaps=numbercaps+1
            do j=1,3
            xmean(j)=xmean(j)+c(nbstore(m),j)
     .      +fact1*(c(mbstore(m),j)-c(nbstore(m),j))
            xcap(numbercaps,j)=c(nbstore(m),j)
     .      +fact1*(c(mbstore(m),j)-c(nbstore(m),j))
            enddo
            nattach(numbercaps)=nbstore(m)
          endif
         endif
        enddo
       enddo

       do k=1,3
       do i=1,nfam(n)
        xmean(k)=xmean(k)+c(ifam(n,i),k)
       enddo
       enddo
       do k=1,3
        xmean(k)=xmean(k)/dble(float(nfam(n)+numbercaps))
       enddo

      k=name1
      if(k.le.9)then
       ca='charge.'//I0(k)//'.chg'
       da='charge.'//I0(k)//'.cart'
       ea='charge.'//I0(k)//'.coord'
       fa='charge.'//I0(k)//'.coord.cap'
       pa='charge.'//I0(k)//'.grp'
      endif
      if(k.gt.9.and.k.le.99)then
      k1=k/10
      k2=k-k1*10
      ca1=I0(k1)
      ca2=I0(k2)
      ca='charge.'//ca1//ca2//'.chg'
      da='charge.'//ca1//ca2//'.cart'
      ea='charge.'//ca1//ca2//'.coord'
      fa='charge.'//ca1//ca2//'.coord.cap'
       pa='charge.'//ca1//ca2//'.grp'
      endif
      if(k.gt.99.and.k.le.999)then
      k1=k/100
      k3=k/10 - INT(k1)*10
      k4=k - INT(k1)*100 - INT(k3)*10
      ca1=I0(k1)
      ca2=I0(k3)
      ca3=I0(k4)
      ca='charge.'//ca1//ca2//ca3//'.chg'
      da='charge.'//ca1//ca2//ca3//'.cart'
      ea='charge.'//ca1//ca2//ca3//'.coord'
      fa='charge.'//ca1//ca2//ca3//'.coord.cap'
       pa='charge.'//ca1//ca2//ca3//'.grp'
      endif
      if(k.gt.999.and.k.le.9999)then
      k1=k/1000
      k2=k/100 - INT(k1)*10
      k3=k/10 - INT(k2)*10-int(k1)*100
      k4=k - INT(k1)*1000 - INT(k3)*10-int(k2)*100
      ca1=I0(k1)
      ca2=I0(k2)
      ca3=I0(k3)
      ca4=I0(k4)
      ca='charge.'//ca1//ca2//ca3//ca4//'.chg'
      da='charge.'//ca1//ca2//ca3//ca4//'.cart'
      ea='charge.'//ca1//ca2//ca3//ca4//'.coord'
      fa='charge.'//ca1//ca2//ca3//ca4//'.coord.cap'
       pa='charge.'//ca1//ca2//ca3//ca4//'.grp'
      endif

      panames(kcharge)=pa
      nend=index(ea," ")-1
      ga=ea(1:nend)//'_atoms'

c calculate the charge and miltiplicity
      nchargetot=0
      numtot=0
      do i=1,nfam(n)
       numtot=numtot+numa(ifam(n,i))
       nchargetot=nchargetot+ichg(ifam(n,i))
      enddo
      numtot=numtot+numbercaps-nchargetot

      numatoms(kcharge)=nfam(n)+numbercaps
      numelects(kcharge)=numtot

      numtot2=numtot/2
      ndg=numtot-2*numtot2
      if(ndg.eq.0)then
       ndegen=1
      else
       ndegen=2
      endif

c make a blank file for group charges
c which will be filled in other scripts/programs
      open(unit=66,file=pa,status='unknown')
      close(unit=66)

#ifdef __GFORTRAN__
      open(unit=66,file=ca,status='unknown')
      write(66,100)(xmean(k),k=1,3),dble(float(nsum))
      close(unit=66)
      open(unit=67,file=da,status='unknown')
      write(67,*)'  The distributed Cartesian multipoles'
      write(67,*) nfam(n)+numbercaps
      open(unit=68,file=ea,status='unknown')
      open(unit=70,file=ga,status='unknown')
#else
      open(unit=66,file=ca,status='unknown',buffered='YES')
      write(66,100)(xmean(k),k=1,3),dble(float(nsum))
      close(unit=66)
      open(unit=67,file=da,status='unknown',buffered='YES')
      write(67,*)'  The distributed Cartesian multipoles'
      write(67,*) nfam(n)+numbercaps
      open(unit=68,file=ea,status='unknown',buffered='YES')
      open(unit=70,file=ga,status='unknown',buffered='YES')
#endif

c     write(68,*)nsum," 1"
      write(68,*)nsum,ndegen
      do i=1,nfam(n)
      write(68,666)atoms(ifam(n,i)),(c(ifam(n,i),k1),k1=1,3)
      write(70,*)ifam(n,i)
      enddo
      do i=1,numbercaps
       write(68,666)'H ',(xcap(i,k1),k1=1,3)
       write(70,*)0
      enddo
      close(unit=68)
      close(unit=70)

#ifdef __GFORTRAN__
      open(unit=69,file=fa,status='unknown')
#else
      open(unit=69,file=fa,status='unknown',buffered='YES')
#endif
      write(69,*)nfam(n),numbercaps,n
      do i=1,numbercaps
       nsite=0
       do i1=1,nfam(n)
        if(nattach(i).eq.ifam(n,i1))nsite=i1
       enddo
       if(nsite.eq.0)then
        write(6,*)' nsite = 0 in families.f'
        stop
       endif
      write(69,333)(xcap(i,k1),k1=1,3),nsite
      enddo
333   format(3f14.7,I10)
      close(unit=69)

      write(83,*) nfam(n)+numbercaps
      write(83,*)nfam(n)
      do i=1,nfam(n)
       write(67,*)atoms(ifam(n,i))
       do k1=1,3
        write(67,*)c(ifam(n,i),k1)*bohr
       enddo
        write(90,333)(c(ifam(n,i),k1)*bohr,k1=1,3)
      write(83,666)atoms(ifam(n,i)),(c(ifam(n,i),k1),k1=1,3)
666   format(a2,3f13.6,i10)
       write(67,*)'  Charge'
       if(i.eq.1)then
        write(67,*) dble(float(nsum))
       else
        write(67,*) 0.d0
       endif
       write(67,*)'  Dipole'
       do k1=1,3
        write(67,*) 0.d0
       enddo
       write(67,*)'  Quodrupole'
       do k1=1,3
       do k2=1,k1
        write(67,*) 0.d0
       enddo
       enddo
       write(67,*)'  Octapole'
       do k1=1,3
       do k2=1,k1
       do k3=1,k2
        write(67,*) 0.d0
       enddo
       enddo
       enddo
       write(67,*)'  Hexadecapole'
       do k1=1,3
       do k2=1,k1
       do k3=1,k2
       do k4=1,k3
        write(67,*) 0.d0
       enddo
       enddo
       enddo
       enddo
      enddo
      do i=1,numbercaps
       write(67,*)'H '
       do k1=1,3
        write(67,*)xcap(i,k1)*bohr
       enddo
        write(90,333)(xcap(i,k1)*bohr,k1=1,3)
       write(83,666)'H ',(xcap(i,k1),k1=1,3)
       write(67,*)'  Charge'
        write(67,*) 0.d0
       write(67,*)'  Dipole'
       do k1=1,3
        write(67,*) 0.d0
       enddo
       write(67,*)'  Quodrupole'
       do k1=1,3
       do k2=1,k1
        write(67,*) 0.d0
       enddo
       enddo
       write(67,*)'  Octapole'
       do k1=1,3
       do k2=1,k1
       do k3=1,k2
        write(67,*) 0.d0
       enddo
       enddo
       enddo
       write(67,*)'  Hexadecapole'
       do k1=1,3
       do k2=1,k1
       do k3=1,k2
       do k4=1,k3
        write(67,*) 0.d0
       enddo
       enddo
       enddo
       enddo
      enddo

      close(unit=67)
      write(83,*)

c end the nchg if
      endif

c close the natom loop
      enddo

#ifdef __GFORTRAN__
      open(unit=30,file='OUT_ELECTRONS',status='unknown')
#else
      open(unit=30,file='OUT_ELECTRONS',status='unknown',buffered='YES')
#endif
      write(30,*)' The number of charge calculations is'
      write(30,*)kcharge
      if(kcharge.gt.0)then
       write(30,*)' The number of atoms and electrons for charge calcs'
       do j=1,kcharge
        write(30,*)numatoms(j),numelects(j),panames(j)
       enddo
      endif

c output the identities of the groups which contain formal charges
c and the associated numbers of the charged atoms

#ifdef __GFORTRAN__
      open(unit=66,file='OUT_CHARGEDGROUPS',status='unknown')
#else
      open(unit=66,file='OUT_CHARGEDGROUPS',status='unknown',
     .             buffered='YES')
#endif
      write(66,*)' The number of groups with formal charges is'
      write(66,*)kcharge
      write(66,*)' The group numbers,# of charges, and atom numbers are'
      do j=1,kcharge
       write(66,*)kgroup(j)
       write(66,*)numchgs(j)
       write(66,*)(natchg(j,k),k=1,numchgs(j))
       write(66,*)
      enddo
      close(unit=66)

c output the charged groups for viewing
#ifdef __GFORTRAN__
      open(unit=66,file='VIEWCHARGEDGROUPS',status='unknown')
#else
      open(unit=66,file='VIEWCHARGEDGROUPS',status='unknown',
     .             buffered='YES')
#endif
      write(66,*)natomall
      write(66,*)
      do j=1,natomall
      write(66,666)atoms(j),(c(j,k),k=1,3)
      enddo
      do j=1,kcharge
      if(formal(kgroup(j)).eq.1)then
       write(66,*)nfam(kgroup(j))
       write(66,667)(ifam(kgroup(j),m),m=1,nfam(kgroup(j)))
       do m=1,nfam(kgroup(j))
        write(66,666)atoms(ifam(kgroup(j),m)),(c(ifam(kgroup(j),m),k),k=1,3)
       enddo
      endif
      enddo
667   format(21I6)

c end the Level if
      endif

100   format(4f13.6)

      deallocate(ngp)
      deallocate(kgroup)
      deallocate(numchgs)
      deallocate(natchg)
      deallocate(formal)
      deallocate(numelects)
      deallocate(numatoms)

      if(numcharges.gt.0)deallocate(nchgatoms)

      return
      end


      subroutine zq(imsgin,xmsgin,cmsgin,msgtype,nwds,ierror)
      implicit none
c
c#######################################################################
c
c     purpose -
c
c        this routine sets mesh quantities
c
c             ..........................................................
c             common 1 flags.
c
c             isq  - point sequence number (fitword entry)
c             imd  - model part identifer (fitword entry)
c             itp  - point type identifer (fitword entry)
c             ihb  - hydro boundary condition flag (fitword entry)
c             irb  - radiation boundary condition flag (fitword entry)
c             nn1  - nearest neighbor search flag (no neighbors are ever
c                       changed after the initial search).
c             nn2  - indicates which neighbors have been searched in a
c                       given calculational cycle.
c             icr  - constraint index to applies to this point.
c             iah  - active hydro flag (=0 ==> active, =1 ==> inactive).
c             npf  - neighbor point type flag.
c
c        format: zq/   isq/istart/iend/istep/ sequence #
c        format: zq/   imd/istart/iend/istep/ part name
c        format: zq/   itp/istart/iend/istep/ point type
c        format: zq/   ihb/istart/iend/istep/ hydro b.c.
c        format: zq/   irb/istart/iend/istep/ radiation b.c.
c        format: zq/   nn1/istart/iend/istep/ permanent n.n. flag.
c        format: zq/   nn2/istart/iend/istep/ dynamic n.n. flag.
c        format: zq/   icr/istart/iend/istep/ constraint flag.
c        format: zq/   iah/istart/iend/istep/ active hydro flag.
c        format: zq/   npf/istart/iend/istep/ neighbor point flag.
c
c             ..........................................................
c             common 2 flags.
c
c             isn  - sequence number.
c
c             ..........................................................
c             source flags.
c
c             iss  - energy source index
c             its  - temperature source index
c             ips  - pressure source index
c             ivs  - velocity (or acceleration) source index
c
c        format: zq/   iss/istart/iend/istep/ source # / start time
c        format: zq/   its/istart/iend/istep/ source # / start time
c        format: zq/   ips/istart/iend/istep/ source # / start time
c        format: zq/   ivs/istart/iend/istep/ source # / start time
c
c             ..........................................................
c             primary variables.
c
c               x  - x-coordinate for a specific mass point
c               y  - y-coordinate for a specific mass point
c               z  - z-coordinate for a specific mass point
c               u  - x-velocity for a specific mass point
c               v  - y-velocity for a specific mass point
c               w  - z-velocity for a specific mass point
c            pmat  - material pressure
c             rho  - material density
c           einter - internal energy
c             tmat - material temperature
c            trad  - radiation temperature
c            prad  - radiation pressure
c           xmass  - mass associated with a point
c          volume  - volume associated with a point
c         velocity - radial velocity relative to an arbitrary center
c           radius - radial position relative to an arbitrary center
c
c        format: zq/     x/istart/iend/istep/  x-coordinate
c        format: zq/     y/istart/iend/istep/  y-coordinate
c        format: zq/     z/istart/iend/istep/  z-coordinate
c        format: zq/     u/istart/iend/istep/  x-velocity
c        format: zq/     v/istart/iend/istep/  y-velocity
c        format: zq/     w/istart/iend/istep/  z-velocity
c        format: zq/  pmat/istart/iend/istep/  pressure
c        format: zq/   rho/istart/iend/istep/  density
c        format: zq/einter/istart/iend/istep/  internal energy
c        format: zq/  tmat/istart/iend/istep/  material temperature
c        format: zq/  trad/istart/iend/istep/  radiation temperature
c        format: zq/  prad/istart/iend/istep/  radiation pressure
c        format: zq/ xmass/istart/iend/istep/  mass
c        format: zq/volume/istart/iend/istep/  volume
c        format: zq/velocity/istart/iend/istep/velocity/xcen/ycen/zcen
c        format: zq/  radius/istart/iend/istep/  radius/xcen/ycen/zcen
c
c
c     input arguments -
c
C        imsgin()  - Integer array of command input tokens
C        xmsgin()  - Real array of command input tokens
C        cmsgin()  - Character array of command input tokens
C        msgtype() - Integer array of command input token types
C        nwds      - Number of command input tokens
c
c     output arguments -
c
C        ierror - Error Return Code (==0 ==> OK, <>0 ==> Error)
c
c     change history -
C
C        $Log: zq.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.2   Thu Feb 03 08:42:38 2000   dcg
CPVCS
CPVCS       Rev 1.1   25 Jan 2000 09:36:20   dcg
CPVCS
CPVCS       Rev 1.47   Fri Sep 03 15:49:20 1999   dcg
CPVCS    get rid of unused options
CPVCS
CPVCS       Rev 1.46   Tue Aug 24 13:35:28 1999   llt
CPVCS    testing
CPVCS
CPVCS       Rev 1.45   Fri Mar 12 12:33:10 1999   dcg
CPVCS    if nwds < 6 print out basic info if not special case
CPVCS
CPVCS       Rev 1.44   Tue Jul 21 08:29:08 1998   dcg
CPVCS    treat ipt1 as itp, icr1 as icr
CPVCS
CPVCS       Rev 1.43   Wed Dec 17 14:33:46 1997   dcg
CPVCS    remove unused cmo_get_info calls
CPVCS
CPVCS       Rev 1.42   Thu Dec 04 17:31:08 1997   dcg
CPVCS    fix bad go to if no attribute found
CPVCS
CPVCS       Rev 1.41   Mon Dec 01 16:31:56 1997   dcg
CPVCS    remove a few obsolete variables
CPVCS
CPVCS       Rev 1.40   Mon Nov 24 16:38:28 1997   dcg
CPVCS     use geom.h and calls to get_regions, get_mregions, get_surfaces
CPVCS    to access geometry data - start to isolate integer*8 dependencies
CPVCS
CPVCS       Rev 1.38   Mon Nov 17 10:39:54 1997   dcg
CPVCS    remove obsolete code
CPVCS
CPVCS       Rev 1.37   Fri Oct 31 10:51:32 1997   dcg
CPVCS    declare ipcmoprm as a pointer
CPVCS
CPVCS       Rev 1.36   Mon Apr 14 17:06:20 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.35   Mon Apr 14 16:15:38 1997   llt
CPVCS    No change.
CPVCS
CPVCS       Rev 1.34   Fri May 24 16:10:10 1996   dcg
CPVCS    fix dimension on vels, get rid of int
CPVCS
CPVCS       Rev 1.33   Sat Mar 09 10:28:38 1996   dcg
CPVCS    replace hollerith in format statements
CPVCS
CPVCS       Rev 1.32   Tue Mar 05 12:50:34 1996   dcg
CPVCS    remove int1, icn1
CPVCS
CPVCS       Rev 1.31   Mon Feb 26 13:44:54 1996   dcg
CPVCS    fixed bug with printing velocities
CPVCS
CPVCS       Rev 1.30   Fri Feb 23 16:38:10 1996   dcg
CPVCS    use dictionary to retrieve velocity names
CPVCS
CPVCS       Rev 1.29   Mon Feb 12 16:15:56 1996   dcg
CPVCS    list option works for added attributes
CPVCS    rank is now looked at for added attributes
CPVCS
CPVCS       Rev 1.28   11/20/95 09:10:08   dcg
CPVCS    test for npoints=0 then return
CPVCS
CPVCS       Rev 1.27   11/17/95 15:21:54   dcg
CPVCS    replace literal character strings in calls
CPVCS
CPVCS       Rev 1.26   11/16/95 15:23:06   dcg
CPVCS    replace character literals in calls
CPVCS
CPVCS       Rev 1.25   11/07/95 17:29:16   dcg
CPVCS    change flag to 2 in mmgetblk calls
CPVCS
CPVCS       Rev 1.24   09/29/95 09:13:00   het
CPVCS    Put in added attributes inheritance
CPVCS
CPVCS       Rev 1.23   09/19/95 08:43:48   dcg
CPVCS    allow integer type for added attribute
CPVCS
CPVCS       Rev 1.22   09/18/95 19:43:42   dcg
CPVCS    look for mesh object added attributes
CPVCS
CPVCS       Rev 1.21   08/31/95 11:54:12   dcg
CPVCS    fix default points limits (ipointi,ipointj)
CPVCS
CPVCS       Rev 1.20   08/29/95 12:15:32   dcg
CPVCS    set length for names to 40 characters
CPVCS
CPVCS       Rev 1.19   08/23/95 06:59:40   het
CPVCS    Remove the CMO prefix from SB-ids
CPVCS
CPVCS       Rev 1.18   08/22/95 06:51:36   het
CPVCS    Split the storage block for CMO variables.
CPVCS
CPVCS       Rev 1.17   07/17/95 16:00:24   dcg
CPVCS    use names for point types
CPVCS
CPVCS       Rev 1.16   07/15/95 02:21:20   het
CPVCS    Correct an error with ipointi and ipointj
CPVCS
CPVCS       Rev 1.15   06/27/95 16:38:48   dcg
CPVCS    remove second literal argument in memory management calls
CPVCS
CPVCS       Rev 1.14   06/20/95 15:41:52   dcg
CPVCS    remove character literals from arguments list to hgetprt
CPVCS
CPVCS       Rev 1.13   06/19/95 16:43:58   dcg
CPVCS    add blank after literal in calling sequence to savpart
CPVCS
CPVCS       Rev 1.12   06/13/95 09:04:22   ejl
CPVCS    Cleaned up msgtty, calling arguments.
CPVCS
CPVCS
CPVCS       Rev 1.11   06/07/95 15:32:34   het
CPVCS    Change character*32 idsb to character*132 idsb
CPVCS
CPVCS       Rev 1.10   05/15/95 13:36:56   het
CPVCS    Make changes to the regset and surfset routines
CPVCS
CPVCS       Rev 1.9   05/01/95 08:37:00   het
CPVCS    Modifiy all the storage block calles for long names
CPVCS
CPVCS       Rev 1.8   03/31/95 09:11:30   het
CPVCS    Add the buildid calles before all storage block calls
CPVCS
CPVCS       Rev 1.7   03/30/95 05:01:02   het
CPVCS    Change the storage block id packing and preidsb to buildid for long names
CPVCS
CPVCS       Rev 1.6   03/23/95 22:59:44   het
CPVCS    Add the model routines and add the cmo name into the idsbs
CPVCS
CPVCS       Rev 1.5   03/23/95 15:08:54   dcg
CPVCS     Add mesh object name to storage block id for surface,region info.
CPVCS
CPVCS       Rev 1.4   03/10/95 17:12:50   dcg
CPVCS     put in mesh object calls
CPVCS
CPVCS       Rev 1.3   02/18/95 06:57:38   het
CPVCS    Changed the parameter list to be the same as pntlimc
CPVCS
CPVCS       Rev 1.2   01/04/95 22:06:46   llt
CPVCS    unicos changes (made by het)
CPVCS
CPVCS       Rev 1.1   12/19/94 08:27:34   het
CPVCS    Add the "comdict.h" include file.
CPVCS
CPVCS
CPVCS       Rev 1.0   11/10/94 12:20:42   pvcs
CPVCS    Original version.
C
c
c#######################################################################
c
c
c#######################################################################
c
      integer nplen
      parameter (nplen=1000000)
c
      character*132 logmess

c
      pointer (ipisetwd, isetwd)
      pointer (ipimt1, imt1)
      pointer (ipitp1, itp1)
      pointer (ipicr1, icr1)
      pointer (ipisn1, isn1)
      pointer (ipxic, xic)
      pointer (ipyic, yic)
      pointer (ipzic, zic)
      integer isetwd(nplen)
      integer imt1(nplen), itp1(nplen),
     *        icr1(nplen), isn1(nplen)
      real*8 xic(nplen), yic(nplen), zic(nplen)
      pointer ( ipmpary1 , mpary1(1) )
      integer mpary1

c
      pointer ( ipies , ies1(1) )
      pointer ( iptmes , tmes1(1) )
      pointer ( ipits , its1(1) )
      pointer ( iptmts , tmts1(1) )
      pointer ( ipips , ips1(1) )
      pointer ( iptmps , tmps1(1) )
      pointer ( ipivs , ivs1(1) )
      pointer ( iptmvs , tmvs1(1) )
      pointer (ip,out)
      real*8 out(*)
c
      integer nwds, imsgin(nwds), msgtype(nwds)
      REAL*8 xmsgin(nwds)
      character*(*) cmsgin(nwds)
C
      integer ierror
C
      character*32 isubname,cnamz
      character*32 ich1,ich2,ich3, cmo, crank, ctype

      pointer(ipxfield,xfield)
      real*8 xfield(1000000)
      pointer(ipxfield,ifield)
      pointer (ipvels,vels)
      real*8 vels(3,1000000)
      integer ifield(1000000)
C
      character*32 iword, iword1, cvelnm
      character*8 cpart
      character*132 iformat
      real*8 tmdvs,tmdss,uradius,radius,emat,rho,pmat,prad,tmat,trad,
     *  wa,va,ua,rout,xa,ya,za,tmdps,tmdts,tmvs1,tmps1,tmts1,
     * tmes1
      integer ivs,ips,its,iss,nptstmp,iout,isn,nn2,nn1,irb,ihb,itp,imt,
     * isq,ier2,ier,lin,itin,ier1,irank,ierror_return,j1,i1,len,
     * icharlnf,icr,if1,if2,i,mpno,ipt1,ipt2,ipt3,itype,icscode,ipointi,
     * ipointj,mmrel2,iunpk,iprt5,iprt4,iprt1,iprt2,iprt3,ihead1,
     * ihead2,ihead3,ihead4,ihead5,ierr,ityp,icmotype,length,npoints,
     * ierrw,ivs1,ips1,l,iatt_index,ilen,ntets,ies1,its1
      character*32 cio,cpers,cinter,clen

c
c#######################################################################
c
c
c     ******************************************************************
c
c     set the memory management path name to be the subroutine name.
c
      isubname='zq'
      cnamz='zq2'
      cpart='part'
      isubname='zq'
c
c  get mesh object
      call cmo_get_name(cmo,ierror)
      if(ierror.ne.0) then
        write(logmess,'(a)') 'ZQ found bad mesh object'
        call writloga('default',0,logmess,0,ierrw)
        go to 9999
      endif
C
      call cmo_get_info('nnodes',cmo,
     *                  npoints,length,icmotype,ierror)
c  check that there are points -- if none return
      if(npoints.eq.0) then
        write(logmess,'(a)') 'npoints = 0 in subroutine z'
        call writloga('default',0,logmess,0,ierrw)
        go to 9999
      endif
      call cmo_get_info('nelements',cmo,
     *                  ntets,length,icmotype,ierror)
      call cmo_get_info('isetwd',cmo,
     *                  ipisetwd,ilen,ityp,ierr)
      call cmo_get_info('imt1',cmo,ipimt1,ilen,ityp,ierr)
      call cmo_get_info('itp1',cmo,ipitp1,ilen,ityp,ierr)
      call cmo_get_info('icr1',cmo,ipicr1,ilen,ityp,ierr)
      call cmo_get_info('isn1',cmo,ipisn1,ilen,ityp,ierr)
      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ierr)
      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ierr)
      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ierr)
c     initialize some variables.
c
      ihead1=0
      ihead2=0
      ihead3=0
      ihead4=0
      ihead5=0
      iprt1=0
      iprt2=0
      iprt3=0
      iprt4=0
      iprt5=0
      iunpk=0
      mmrel2=0
c
c     ******************************************************************
c
c     set the point index boundaries.
c
      ipointi=0
      ipointj=0
      call cmo_get_info('ipointi',cmo,ipointi,ilen,itype,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
      call cmo_get_info('ipointj',cmo,ipointj,ilen,itype,icscode)
      if (icscode .ne. 0) call x3d_error(isubname,'cmo_get_info')
C
      if(msgtype(3).eq.1.and.imsgin(3).eq.0) then
         imsgin(3)=max(1,ipointi)
      endif
      if(msgtype(4).eq.1.and.imsgin(4).eq.0) then
         if(ipointj.le.0.or.imsgin(3).eq.1) then
            imsgin(4)=npoints
         else
            imsgin(4)=ipointj
         endif
      endif
      if(msgtype(5).eq.1.and.imsgin(5).eq.0) then
         imsgin(5)=1
      endif
C
      ich1=' '
      ich2=' '
      ich3=' '
      if(msgtype(3).eq.1) then
        ipt1=max(1,min(imsgin(3),npoints))
        ipt2=max(1,min(imsgin(4),npoints))
        ipt3=max(1,min(imsgin(5),npoints))
      else
        ich1=cmsgin(3)
        ich2=cmsgin(4)
        ich3=cmsgin(5)
      endif
c
c     ******************************************************************
c
c     check point limits and translate to valid limits if necessary.
c
      length=npoints
      call mmgetblk('mpary1',isubname,ipmpary1,length,2,icscode)
      if(msgtype(3).eq.1) then
         call pntlimn(ipt1,ipt2,ipt3,ipmpary1,mpno,npoints,isetwd,itp1)
      elseif(msgtype(3).ne.1) then
         call pntlimc(ich1,ich2,ich3,ipmpary1,mpno,npoints,isetwd,itp1)
      endif
c
c     ******************************************************************
c
c     set requested values for mass points.
c
      do 100 j1=1,mpno
         i1=mpary1(j1)
         iword=cmsgin(2)
         len=icharlnf(iword)
c
c        _______________________________________________________________
c
c        write data for points.
c
         if(iword(1:len).eq.'all') then
            iprt1=1
            iprt2=1
            iprt3=1
            goto 9995
         endif
         if(iword(1:len).eq.'imt') then
            len=len+1
            iword(1:len)='imt1'
         endif
         if(iword(1:len).eq.'isn') then
            len=len+1
            iword(1:len)='isn1'
         endif
c
c
c        set type in common.
c
         if(iword(1:len).eq.'itp'.or.iword(1:len).eq.'itp1') then
            ierror=0
            if(nwds.lt.6) then
               iprt1=1
               goto 9995
            endif
            if(msgtype(6).eq.1) then
              itp1(i1)=imsgin(6)
            elseif (msgtype(6).eq.3) then
               call getptyp(cmsgin(6),itp1(i1),ierror)
               if (ierror.ne.0) call x3d_error(isubname,'getptyp')
            else
               write(logmess,'(a30)') 'illegal argument in zq command'
               call writloga ('default',0,logmess,0,ierr)
            endif
            goto 9998
         endif
c
c
c        set constriants index in common.
c
         if(iword(1:len).eq.'icr'.or.iword(1:len).eq.'icr1') then
            ierror=0
            if(nwds.lt.6) then
               iprt1=1
               goto 9995
            endif
            if(msgtype(6).le.2) then
               icr=imsgin(6)
            elseif(msgtype(6).eq.3) then
               iword=cmsgin(6)
               if1=5
               if2=8
               do 120 i=if1,if2
                  if(iword(i:i).eq.' ') then
                     iformat=' '
                     write(iformat,"('(a',i1,',i',i1,')')") if1-1,i-if1
                     goto 121
                  endif
 120           continue
 121           continue
               read(iword,iformat) iword1,icr
            endif
            icr1(i1)=imsgin(6)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set xyz-coordinates.
c
         if(iword(1:len).eq.'xyz') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            xic(i1)=xmsgin(6)
            yic(i1)=xmsgin(7)
            zic(i1)=xmsgin(8)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set x-coordinate.
c
         if(iword(1:len).eq.'x'.or.iword(1:len).eq.'xic') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            xic(i1)=xmsgin(6)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set y-coordinate.
c
         if(iword(1:len).eq.'y'.or.iword(1:len).eq.'yic') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            yic(i1)=xmsgin(6)
            goto 9998
         endif
c
c        _______________________________________________________________
c
c        set z-coordinate.
c
         if(iword(1:len).eq.'z'.or.iword(1:len).eq.'zic') then
            ierror=0
            if(nwds.lt.6) then
               iprt2=1
               goto 9995
            endif
            zic(i1)=xmsgin(6)
            goto 9998
         endif
c        _______________________________________________________________
c      look for added attribute
c
         if(nwds.le.5) then
           iprt1=1
           iprt2=1
           go to 9995
         endif
         if(j1.eq.1) then
            call  cmo_get_attparam(iword,cmo,iatt_index,ctype,crank,
     *      clen,cinter,cpers,cio,ierror_return)
            if(icscode.eq.0) then
C   found existing attribute
               if(ctype(1:4).eq.'VINT') ityp=1
               if(ctype(1:7).eq.'VDOUBLE') ityp=2
               call mmgetpr(iword(1:len),cmo,ipxfield,icscode)
               call cmo_get_info(crank,cmo,irank,lin,itin,ier1)
            else
               write(logmess,9005) iword(1:len),cmo
               call writloga('default',0,logmess,0,ierrw)
               go to 9998
            endif
         endif
         ierror=0
         if((j1.eq.1.and.icscode.eq.0.and.ier.eq.0.and.ier1.eq.0.and.
     *            ier2.eq.0).or.j1.ne.1) then
            if(msgtype(6).eq.2) then
               do l=1,irank
                  xfield((i1-1)*irank+l)=xmsgin(6)
               enddo
            elseif(msgtype(6).eq.1) then
               do l=1,irank
                  ifield((i1-1)*irank+l)=imsgin(6)
               enddo
            elseif(nwds.lt.6) then
               do l=1,irank
                  if(ityp.eq.1) write(logmess,'(i6,i6)') i1,
     *                 ifield((i1-1)*irank+l)
                  if(ityp.eq.2) write(logmess,'(i6,e10.3)') i1,
     *                 xfield((i1-1)*irank+l)
                  call writloga('default',0,logmess,0,ierrw)
               enddo
            endif
         else
            write(logmess,9005) iword(1:len),cmo
 9005       format(' zq cannot find attribute ',a,' in ',a)
            call writloga('default',0,logmess,0,ierrw)
            go to 9997
         endif
c        _______________________________________________________________
c
c        invalid option used if this location reached.
c
         goto 9998
c
c        _______________________________________________________________
c
c        write point data to log files.
c
 9995    continue
c
         ierror=0
         if(ihead1.eq.0) then
            ihead1=1
            if(iprt1.eq.1) then
               write(logmess,9000)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         if(ihead2.eq.0) then
            ihead2=1
            if(iprt2.eq.1) then
               write(logmess,9030)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         if(ihead3.eq.0) then
            ihead3=1
            if(iprt3.eq.1) then
               write(logmess,9050)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         if(ihead4.eq.0) then
            ihead4=1
            if(iprt4.eq.1) then
               write(logmess,9070)
               call writloga('default',0,logmess,0,ierr)
            endif
         endif
         isq=0
         imt=imt1(i1)
         itp=itp1(i1)
         ihb=0
         irb=0
         nn1=0
         nn2=0
Cdcg     int=int1(i1)
         icr=icr1(i1)
Cdcg     icn=icn1(i1)
         isn=isn1(i1)
c
         if(iprt1.eq.1) then
            write(logmess,9010) i1,isq,imt,itp,icr,isn
            call writloga('default',0,logmess,0,ierr)
         endif
         if(iprt2.eq.1) then
            xa=xic(i1)
            ya=yic(i1)
            za=zic(i1)
            if(j1.eq.1)
     *        call cmo_get_attinfo('velname',cmo,iout,rout,cvelnm,
     *         ip,length,itype,ier)
            if(ier.eq.0.and.j1.eq.1)
     *        call cmo_get_info(cvelnm,cmo,ipvels,length,itype,ier)
            if(ier.eq.0) then
               ua=vels(1,i1)
               va=vels(2,i1)
               wa=vels(3,i1)
            else
               ua=0.
               va=0.
               wa=0.
            endif
            write(logmess,9040) i1,xa,ya,za,ua,va,wa
            call writloga('default',0,logmess,0,ierr)
         endif
Cdcg     pmat=pic(i1)
Cdcg     rho=ric(i1)
Cdcg     emat=eic(i1)
         tmat=0.0
         trad=0.0
         prad=0.0
         if(iprt3.eq.1) then
            write(logmess,9040) i1,rho,emat,tmat,trad,pmat,prad
            call writloga('default',0,logmess,0,ierr)
         endif
c
         if(iprt4.eq.1) then
            radius=sqrt(xic(i1)*xic(i1)+yic(i1)*yic(i1)
     *              +zic(i1)*zic(i1) )
            call cmo_get_attinfo('velname',cmo,iout,rout,cvelnm,
     *       ip,length,itype,ier)
            call cmo_get_info(cvelnm,cmo,ipvels,length,itype,ier)
            if(ier.eq.0) then
               uradius=
     *          sqrt(vels(1,i1)*vels(1,i1)+vels(2,i1)*vels(2,i1)
     *              +vels(3,i1)*vels(3,i1) )
            else
               uradius=0.
            endif
            write(logmess,9040) i1,radius,uradius
            call writloga('default',0,logmess,0,ierr)
         endif

        if(iprt5.eq.1) then
           if(nptstmp.le.0) then
              write(logmess,9082)
              call writloga('default',0,logmess,0,ierr)
9082          format('no source points have been assigned.')
           else
             iss=ies1(i1)
              tmdss=tmes1(i1)
              its=its1(i1)
              tmdts=tmts1(i1)
              ips=ips1(i1)
              tmdps=tmps1(i1)
              ivs=ivs1(i1)
              tmdvs=tmvs1(i1)
              write(logmess,9080) i1,iss,tmdss,its,tmdts,ips,tmdps,ivs,
     *                            tmdvs
              call writloga('default',0,logmess,0,ierr)
9080          format(i5,2x,4(i4,2x,1pe12.4))
           endif
        endif
 9000    format('      ipt',' isq',' imt',' itp',' icr',' isn')
 9010    format(i9,4i4,i9)
 9030    format(1x,'ipt',9x,'xa',10x,'ya',10x,'za',
     *                         10x,'ua',10x,'va',10x,'wa')
 9040    format(i5,2x,6(1pe12.4))
 9050    format(1x,'ipt',8x,'rho ',8x,'emat',8x,'tmat',
     *                         8x,'trad',8x,'pmat',8x,'prad')
 9070    format(1x,'ipt',5x,'radius',4x,'velocity')
         goto 9998
 9998    continue
c
c        _______________________________________________________________
c
 100  continue
c
c     ******************************************************************
c
c     release any local memory allocated for this routine.
c
 9997 call mmrelblk('mpary1',isubname,ipmpary1,icscode)
c
c     if (mmrel2 .ne. 0) call mmrelprt(cnamz, ics)
c
c
c     ******************************************************************
c
c     error returns transfer to this statement 9999
c
      goto 9999
 9999 continue
c
c     ******************************************************************
c
      return
      end


  subroutine initam( )

! ====================================================================
!
! Initializes several common blocks and calls to setup constants/decay table
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    logical :: lprnt

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

    logical ::    nodcay,noeta,nopi0,nonunu,noevol,nohadr,noka0
    common/nodcay/nodcay,noeta,nopi0,nonunu,noevol,nohadr,noka0
    integer(int32) :: itdky, itevt, itcom, itlis
    common/itapes/itdky,itevt,itcom,itlis
    logical iprint
    common/prints/iprint
    logical notre
    common/notre/ notre
    real(real64) :: enbou
    common/comenb/ enbou
    integer(int32) :: icms
    common/comfr/  icms
    logical yesela
    common/yesela/ yesela
    logical keyhh
    common/keyhh/ keyhh
    logical keypla
    common/keypla/ keypla
    logical qsee,qvsee
    common/comqse/ qsee,qvsee
    integer(int32) :: inside
    common/cinsid/ inside
    integer(int32) :: ivalon
    common/cvalon/ ivalon
    logical wtime
    common/comwti/ wtime
    integer(int32) :: iorhei
    common/iorhei/ iorhei
    integer(int32) :: isob3
    common/isob3/ isob3

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

    itcom=15
    itlis=16
    itevt=17
    itdky=18
    nodcay=.false.
    notre=.false.
    lprnt=.false.
!    LPRNT=.TRUE.
    iprint=.false.
    yesela=.false.
    keyhh=.false.
    keypla=.false.
    qsee=.false.
    qvsee=.false.
!    WTIME=.TRUE.
    wtime=.false.
    enbou= 4.4
    inside=0
    ivalon=0
    iorhei=1
    isob3=1

    ! IF LAB. FRAME
    ICMS=0
    ! IF  C.M. FRAME
    icms=1

    call setcon
    call setdky(lprnt)
    return
! ====================================================================
  end subroutine initam

  subroutine setcon

! ====================================================================
!
! THIS SUBROUTINE SETS THE CONSTANTS IN /CONST/.
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none

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

!    COMMON/ITAPES/ITDKY,ITEVT,ITCOM,ITLIS
    real(real64) :: pi, sqrt2, alf, gf, units
    common/const/pi,sqrt2,alf,gf,units

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

    pi    = 4.*atan(1.0d0)
    sqrt2 = sqrt(2.0d0)
    alf   = 1./137.036
    gf    = 1.16570d-5
    units = 1./2.56815

    return
! ====================================================================
  end subroutine setcon

  subroutine setdky(lprint)

! ====================================================================
!
!          THIS SUBROUTINE READS IN THE DECAY TABLE FROM TAPE ITDKY
!          AND SETS UP /DKYTAB/.
!          QUARK-BASED IDENT CODE
!
! ====================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64

    implicit none
    logical, intent(in   ) :: lprint

    integer(int32) :: i, ifl1, ifl2, ifl3, index, iold, ires, itype, &
         & jspin, k, loop
    real(real64)   :: br
    character(len=8) :: lread(10),lmode(6),lres

    integer(int32), dimension(6) :: imode

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

    character(len=*), parameter :: &
         & iquit = " end", &
         & iblank = "     "

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

    integer(int32) :: itdky, itevt, itcom, itlis
    common/itapes/itdky,itevt,itcom,itlis
    integer(int32) :: nforce, iforce, mforce
    common/force/nforce,iforce(20),mforce(5,20)
    ! LOOK MUST BE DIMENSIONED TO THE MAXIMUM VALUE OF INDEX
    integer(int32) :: look, mode
    real(real64)   :: cbr
    common/dkytab/look(400),cbr(600),mode(5,600)
    logical ::    nodcay,noeta,nopi0,nonunu,noevol,nohadr,noka0
    common/nodcay/nodcay,noeta,nopi0,nonunu,noevol,nohadr,noka0

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

    if(lprint) write(itlis,10)
10  format(1h1,30(1h*)/2h *,28x,1h*/ &
         & 2h *,5x,17hcolli decay table,5x,1h*/ &
         & 2h *,28x,1h*/1x,30(1h*)// &
         & 6x,4hpart,18x,10hdecay mode,19x,6hcum br,15x,5hident,17x, &
         & 11hdecay ident/)
    loop=0
    iold=0
    do i = 1, 400
       look(i) = 0
    enddo
    if(nodcay) return
    rewind decayUnit

200 loop=loop+1
    if(loop > 600) go to 9999
! 220 continue
    do i = 1,5
       imode(i)=0
       lmode(i)=iblank
    enddo

! Reading file ITDKY
    ! (check if file associated with an open unit)
    ! (NOTE: decayUnit == -1 if file NOT opened)
    inquire(file = effectiveDecayFile, &
         & number = decayUnit)

    ! Open file (not connected to any other unit)
    if (decayUnit == -1_int32) &
         & open(newunit = decayUnit, &
         & file = effectiveDecayFile, &
         & status = "old", action = "read")
    read(decayUnit,*,end=300) ires,itype,br,(imode(i),i=1,5)
    if(ires == 0) go to 300
!     IF(NOPI0.AND.IRES.EQ.110) GO TO 220
!     IF(NOETA.AND.IRES.EQ.220) GO TO 220
    if(ires == iold) go to 230
    call flavor(ires,ifl1,ifl2,ifl3,jspin,index)
    look(index)=loop
230 iold=ires
    cbr(loop)=br
    do i=1,5
       mode(i,loop)=imode(i)
       if(imode(i).ne.0) call label(lmode(i),imode(i))
    enddo
    call label(lres,ires)
    if(lprint) write(itlis,20) lres,(lmode(k),k=1,5), &
         & br,ires,(imode(k),k=1,5)
20  format(6x,a5,6x,5(a5,2x),3x,f8.5,15x,i5,4x,5(i5,2x))
    go to 200
!          SET FORCED DECAY MODES
300 if(nforce == 0) go to 400
    do i=1,nforce
       loop=loop+1
       if(loop > 600) go to 9999
       call flavor(iforce(i),ifl1,ifl2,ifl3,jspin,index)
       look(index)=loop
       do k = 1,5
          mode(k,loop)=mforce(k,i)
       enddo
       cbr(loop)=1.
    enddo

!  READ AND PRINT NOTES FROM DECAYTABLE FILE
400 if(lprint) then
410    read(decayUnit,1002,end=9998) lread
1002   format(10a8)
       if(lread(1) == iquit) go to 9998
       write(itlis,1003) lread
1003   format(1x,10a8)
       go to 410
    end if

    close(decayUnit)
9998 return

9999 write(itlis,30)
30  format(//44h ***** error in setdky ... loop.GT.600 *****)
    close(decayUnit)
    return
! ====================================================================
  end subroutine setdky


**==popmet.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      FUNCTION POPMET(N,Ij,Emet,Dene,T)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL a21 , b21 , bee , bm1 , bmm , c , c21 , cm1 , cmm , cn ,
     &     CONce , cpr , Dene , DNE , e1 , e2 , e3 , ebe , ecm , Emet
      REAL emg , eres , fc , GNDrec , HENeut , HEPlus , PCOol , PLN ,
     &     PM , POPMET , pops , POT , POU , POWer , r , r5 , rb5 , rbe ,
     &     rc5 , RE
      REAL REDuc , RHY , rm1 , rm5 , rmm , rres , st , sum , sumc , T ,
     &     TLN , TU , v , x
      INTEGER i , Ij , j , N , nj , nn , no , NOSON , np
C*** End of declarations inserted by SPAG
C  RETURNS POPULATION OF METASTABLE LEVEL OF BE,B,C, OR MG-LIKE ION;  CARBON-NICKEL
C  RESONANCE CONTRIBUTIONS CALC FOR HIGH Z WITH SMITH ET AL METHOD
C  PASSES REDUC BACK TO GAUNT FOR INTERCOMBINATION LINES

      REAL mgmm , mgm1 , mgm5 , mg21 , mg5 , mg1

      DIMENSION rm5(12) , ebe(12) , pops(4)
      DIMENSION mgmm(3,7) , mgm1(7) , mg5(7) , mg21(2,7) , emg(7)
      DIMENSION nj(30) , a21(2,12) , b21(3,12) , c21(3,12) , rm1(12)
      DIMENSION rmm(3,12) , bm1(12) , bmm(3,12) , cm1(3,12) , cmm(2,12)
      DIMENSION ecm(2,12) , r(3,3) , x(3) , c(3) , cpr(3)
      DIMENSION rb5(12) , rc5(12) , rres(4,12) , eres(4,12)
      DIMENSION rbe(12) , bee(12)

      COMMON /RESULT/ CONce(30) , GNDrec(30) , POWer(220) , RHY ,
     &                HENeut , HEPlus , DNE , PCOol , POU , POT , RE ,
     &                TU , PM(4)
      COMMON /INTERC/ REDuc(4)
      COMMON /METLN / PLN(4,3,8) , TLN(4,3,8)

      DATA rm5/0. , 18.6 , 11.7 , 6.09 , 2.79 , 1.54 , .93 , .61 , .41 ,
     &     .31 , .13 , .10/
      DATA ebe/0. , 6.20 , 7.87 , 9.51 , 12.81 , 16.1 , 19.5 , 23.11 ,
     &     26.9 , 28.9 , 55.5 , 63.1/
      DATA mg21/430. , 5.8E-4 , 22000. , .008 , 1.63E+5 , .000 , 9.E+5 ,
     &     .12 , 3.3E+6 , .26 , 4.5E+7 , 1.00 , 8.E+7 , 2./
      DATA mg5/0.2 , 0.5 , .26 , .035 , .026 , .0058 , .0039/

C  GILES QUOTED BY MENDOZA FOR S V, BALUJA FOR SI III

      DATA mgm1/.045 , .35 , .072 , .026 , .016 , .0069 , .0047/
      DATA mgmm/.5 , .38 , 1.5 , 1.4 , 1.06 , 4.1 , .25 , .39 , 1.32 ,
     &     .29 , .21 , .82 , .17 , .13 , .51 , .033 , .25 , .43 , .02 ,
     &     .13 , .30/
      DATA emg/1.63 , 3.72 , 5.50 , 7.13 , 8.72 , 13.9 , 17./
      DATA nj/0 , 1 , 0 , 0 , 0 , 2 , 3 , 4 , 0 , 5 , 0 , 6 , 0 , 7 ,
     &     0 , 8 , 0 , 9 , 0 , 10 , 5*0 , 11 , 0 , 12 , 0 , 0/
      DATA a21/2*0. , 77.2 , .00282 , 471. , .00629 , 1880. , .0118 ,
     &     16200. , .0306 , 84500. , .0629 , 320000. , .112 , 972600. ,
     &     .1823 , 2.546E+6 , .2781 , 5.914E+6 , .4029 , 7.3E+7 , 1.21 ,
     &     1.4E+8 , 1.8/
      DATA b21/3*0. , 332. , 130. , 82. , 1183. , 130. , 347. , 4210. ,
     &     499. , 1470. , 28400. , 3170. , 8910. , 152000. , 19800. ,
     &     56200. , 705000. , 102000. , 288000. , 43790. , 11613. ,
     &     27300. , 4.28E+06 , 7.08E+05 , 2.42E+06 , 1.02E+07 ,
     &     1.55E+06 , 5.62E+06 , 8.E+7 , 1.E+7 , 5.E+7 , 2.E+8 , 2.E+7 ,
     &     1.E+8/
      DATA c21/3*0. , .00031 , .0026 , 32. , .0041 , .0342 , 190. ,
     &     .022 , .16 , 385. , .599 , 4.64 , 6910. , 4.67 , 37.1 ,
     &     45200. , 26.1 , 200. , 197000. , 115. , 856. , 680000. ,
     &     424. , 3000. , 2.0E+06 , 1370. , 9090. , 5.32E+06 , 29400. ,
     &     128000. , 6.7E+7 , 95000. , 380000. , 1.7E+8/

C  REDUCED COLLISION RATES * 10. ** 7

      DATA rm1/0. , 9.384 , 4.944 , 2.814 , 1.340 , .7265 , .4718 ,
     &     .3164 , .2243 , .1732 , .08 , .062/

C  INCLUDES PROTON RATES FROM MUNRO THROUGH SI, EXT F OR S, NONE ABOVE A

      DATA rmm/3*0. , 29.9 , 13.4 , 50.8 , 17.7 , 8.41 , 32.2 , 11.2 ,
     &     6.00 , 21.8 , 6.48 , 4.19 , 13.9 , 3.96 , 3.04 , 9.68 ,
     &     2.91 , 2.67 , 7.96 , 2.19 , 2.42 , 6.83 , 1.25 , 0.40 ,
     &     1.79 , .533 , .317 , 1.40 , .046 , .16 , .67 , .020 , .12 ,
     &     .52/
      DATA bm1/0. , 14. , 8.1 , 5.3 , 4.1 , 3.01 , 2.0 , 1.5 , 1.1 ,
     &     .95 , .67 , .58/
      DATA bmm/3*0. , 23. , 7.9 , 31. , 17.1 , 5.73 , 20.8 , 12.3 ,
     &     4.17 , 14.1 , 6.52 , 2.39 , 7.91 , 3.84 , 1.47 , 3.01 ,
     &     2.65 , 1.01 , 3.16 , 18.6 , 13.9 , 38. , 1.68 , .57 , 1.9 ,
     &     1.34 , .43 , 1.45 , .69 , .18 , .69 , .55 , .14 , .54/
      DATA cm1/3*0. , 12.1 , 12.9 , 10. , 51. , 29.5 , 23. , 12.0 ,
     &     8.6 , 4.18 , 9.1 , 6.4 , 2.92 , 6.75 , 4.72 , 2.1 , 5.39 ,
     &     3.86 , 1.55 , 4.17 , 3.04 , 1.19 , 2.84 , 2.02 , 1.00 ,
     &     2.43 , 1.57 , 0.90 , 1.1 , .75 , .60 , 1.0 , .56 , .54/
      DATA cmm/2*0. , 12.9 , .0005 , 32.5 , .001 , 29. , .0015 , 17.5 ,
     &     .00205 , 11.2 , .00173 , 7.42 , .00173 , 5.44 , .00518 ,
     &     4.1 , .0069 , 3.52 , .0138 , 1.7 , .03 , 1.5 , .05/
      DATA ecm/2*0. , 1.26 , 2.68 , 1.90 , 4.05 , 2.42 , 5.34 , 3.76 ,
     &     7.93 , 5.09 , 10.6 , 6.58 , 13.4 , 8.34 , 16.5 , 10.6 ,
     &     20.1 , 13.5 , 24.5 , 30.1 , 45. , 51. , 62./
      DATA rb5/0. , 25. , 21.6 , 16.9 , 8.80 , 5.23 , 3.64 , 15.5 ,
     &     4*0./
      DATA rc5/12*0./
      DATA bee/0. , 10.5 , 13.4 , 16.3 , 22.1 , 28. , 34. , 40.5 , 4*0./
      DATA rbe/0. , 115. , 95.4 , 78.4 , 47.7 , 32.1 , 24.6 , 18.2 ,
     &     4*0./
      DATA eres/4*0. , 12.7 , 9.25 , 7.94 , 0. , 16.3 , 12.5 , 11.5 ,
     &     0. , 19.7 , 15.8 , 14.9 , 0. , 27.0 , 22.3 , 21.9 , 0. ,
     &     33.8 , 28.8 , 28.9 , 4.35 , 40.9 , 35.8 , 36.3 , 10.3 ,
     &     48.4 , 11.6 , 44.1 , 15.8 , 16*0./
      DATA rres/4*0. , 327. , 95. , 5.9 , 0. , 306. , 111. , 74.9 , 0. ,
     &     229. , 97.8 , 139. , 0. , 141. , 60.7 , 111. , 0. , 96. ,
     &     41.3 , 70.3 , 68.0 , 71.7 , 30.3 , 37.1 , 956. , 52.5 ,
     &     22.0 , 26.5 , 64.3 , 16*0./

      np = 0
      r5 = 0.0
      mgm5 = 0.0

      DO 100 i = 1 , 3
         DO 50 j = 1 , 3
            r(i,j) = 0.
 50      CONTINUE
 100  CONTINUE
c  avoid overflow for low t

      REDuc(Ij) = 0.
      POPMET = 0.
      IF ( Emet*11590./T.GE.30. ) RETURN
      st = SQRT(T)
      no = nj(N)
      v = Dene*1.E-7/st
      IF ( Ij.EQ.2 ) THEN
C  B-LIKE IONS
         cn = CONce(N-4)
         r5 = rb5(no)*v*EXP(-11590.*(eres(2,no)-Emet)/T)
         r(1,1) = -(bm1(no)+bmm(1,no)*2.+bmm(2,no)*3.)*v - b21(1,no)
         r(2,2) = -(bm1(no)+bmm(1,no)+bmm(3,no)*1.5)*v - b21(2,no)
         r(3,3) = -(bm1(no)+bmm(2,no)+bmm(3,no))*v - b21(3,no)
         r(2,1) = v*bmm(1,no)*2.
         r(3,1) = v*bmm(2,no)*3.
         r(1,2) = v*bmm(1,no)
         r(1,3) = v*bmm(2,no)
         r(3,2) = v*1.5*bmm(3,no)
         r(2,3) = v*bmm(3,no)
         c(1) = -bm1(no)*EXP(-Emet*11590./T)*v/3.
         c(2) = c(1)*2.
         c(3) = c(1)*3.
      ELSEIF ( Ij.EQ.3 ) THEN
C  C-LIKE IONS
         cn = CONce(N-5)
         r5 = rc5(no)*v*EXP(-11590.*(eres(3,no)-Emet)/T)
         e1 = EXP(-ecm(1,no)*11590./T)
         e2 = EXP(-ecm(2,no)*11590./T)
         e3 = EXP(-Emet*11590./T)
         r(1,1) = -(cm1(1,no)+cmm(1,no)*.2*e2/e1+cmm(2,no)*e3/e1)
     &            *v - c21(1,no)
         r(2,2) = -(cm1(2,no)+cmm(1,no))*v - c21(2,no)
         r(3,3) = -(cm1(3,no)+cmm(2,no))*v - c21(3,no)
         r(2,1) = v*cmm(1,no)*.2*e2/e1
         r(1,2) = v*cmm(1,no)
         r(3,1) = v*cmm(2,no)*e3/e1
         r(1,3) = v*cmm(2,no)
         r(3,2) = 0.
         r(2,3) = 0.
         c(1) = -cm1(1,no)*v*5.*e1/9.
         c(2) = -cm1(2,no)*v*e2/9.
         c(3) = -cm1(3,no)*v*e3*5./9.
      ELSEIF ( Ij.EQ.4 ) THEN
         cn = CONce(N-11)
         v = 8.63E-6*Dene/st
         np = no - 5
         mg1 = v*mgm1(np)
         mgm5 = v*mg5(np)*EXP(-11590.*emg(np)/T)
         IF ( N.EQ.14 ) mgm5 = mgm5/(1.+8.6E-6*T)
         IF ( N.EQ.14 ) mg1 = mg1/(1.+T*3.5E-6)
         r(1,1) = -mg1 - mgm5 - mgmm(1,np)*v - mgmm(2,np)*v
         r(2,2) = -mg1 - mgm5 - mgmm(1,np)*v/3 - mgmm(3,np)
     &            *v/3 - mg21(1,np)
         r(3,3) = -mg1 - mgm5 - mg21(2,np) - mgmm(2,np)
     &            *v/5. - mgmm(3,np)*v/5.
         r(2,1) = v*mgmm(1,np)
         r(3,1) = v*mgmm(2,np)
         r(1,2) = v*mgmm(1,np)/3.
         r(1,3) = v*mgmm(2,np)/5.
         r(3,2) = v*mgmm(3,np)/3.
         r(2,3) = v*mgmm(3,np)/5.
         c(1) = -mg1*EXP(-11590.*Emet/T)
         c(2) = c(1)*3.
         c(3) = c(1)*5.
      ELSE
         cn = CONce(N-3)
         r(1,1) = -(rm1(no)+rmm(1,no)*3.+rmm(2,no)*5.)*v
         r(2,2) = -a21(1,no) - v*(rm1(no)+rmm(1,no)+rmm(3,no)*1.6666667)
         r(3,3) = -a21(2,no) - v*(rm1(no)+rmm(2,no)+rmm(3,no))
         r5 = rm5(no)*v*EXP(-11590.*ebe(no)/T)
         r(1,1) = r(1,1) - r5
         r(2,2) = r(2,2) - r5
         r(3,3) = r(3,3) - r5
         r(2,1) = v*rmm(1,no)*3.
         r(3,1) = v*rmm(2,no)*5.
         r(1,2) = v*rmm(1,no)
         r(1,3) = v*rmm(2,no)
         r(3,2) = v*1.666667*rmm(3,no)
         r(2,3) = v*rmm(3,no)
         c(1) = -rm1(no)*EXP(-Emet*11590./T)*v
         c(2) = c(1)*3.
         c(3) = c(1)*5.
      ENDIF
      nn = NOSON(r,x,3,3)
      IF ( nn.EQ.0 ) PRINT 99001
      DO 200 i = 1 , 3
         cpr(i) = 0.
         DO 150 j = 1 , 3
            cpr(i) = cpr(i) + r(i,j)*c(j)
 150     CONTINUE
 200  CONTINUE
      sum = 1. + cpr(1) + cpr(2) + cpr(3)
      pops(1) = 1./sum
      pops(2) = cpr(1)/sum
      pops(3) = cpr(2)/sum
      pops(4) = cpr(3)/sum
      POPMET = (cpr(1)+cpr(2)+cpr(3))/sum
      IF ( Ij.EQ.3 ) POPMET = cpr(3)/sum
      fc = 1.E23*1.6E-12*cn/Dene
      IF ( Ij.EQ.2 ) THEN
         PLN(2,1,no) = (pops(1)*rres(2,no)*v*EXP(-11590.*eres(2,no)/T)
     &                 +POPMET*r5)*fc*eres(2,no)
         PLN(2,3,no) = (pops(2)*b21(1,no)+pops(3)*b21(2,no)+pops(4)
     &                 *b21(3,no))*fc*Emet
         sumc = -c(1) - c(2) - c(3)
         REDuc(2) = (pops(2)*b21(1,no)+pops(3)*b21(2,no)+pops(4)
     &              *b21(3,no))/sumc
         RETURN
      ELSEIF ( Ij.EQ.3 ) THEN
         PLN(3,1,no) = (pops(1)*rres(3,no)*v*EXP(-11590.*eres(3,no)/T)
     &                 +POPMET*r5)*fc*eres(3,no)
         PLN(3,3,no) = pops(4)*c21(3,no)*fc*Emet
         REDuc(3) = -pops(4)*c21(3,no)/c(3)
         RETURN
      ELSEIF ( Ij.NE.4 ) THEN
C  ERGS * 10-23 / S / ATOM
         PLN(1,1,no) = (pops(1)*rres(1,no)*v*EXP(-11590.*eres(1,no)/T)
     &                 +POPMET*r5)*fc*eres(1,no)
         PLN(1,2,no) = POPMET*v*rbe(no)*EXP(-11590.*bee(no)/T)
     &                 *fc*bee(no)
         PLN(1,3,no) = pops(3)*a21(1,no)*Emet*fc
         sumc = -c(1) - c(2) - c(3)
         REDuc(1) = (pops(3)*a21(1,no)+pops(4)*a21(2,no))/sumc
         RETURN
      ENDIF
      PLN(4,1,no) = (pops(1)*rres(4,no)*v*EXP(-11590.*eres(4,no)/T)
     &              +POPMET*mgm5)*fc*eres(4,no)
      PLN(4,3,no) = pops(3)*mg21(1,np)*fc*Emet
      sumc = -c(1) - c(2) - c(3)
      REDuc(4) = (pops(3)*mg21(1,np)+pops(4)*mg21(2,np))/sumc
      RETURN
99001 FORMAT (' BAD INVERSION')
      END


subroutine read_radar_wind_ascii(nread,ndata,nodata,infile,lunout,obstype,sis,hgtl_full,nobs)
!$$$   subprogram documentation block
!                .      .    .                                       .
!   subprogram: read_dbz        read level2 raw QC'd radial velocity data
!
!   prgmmr: carley          org: np22                date: 2011-05-24
!
! abstract: Reads and processes level 2 horizontal radial velocity (m/s) by
!                radar site.  Data are on radar scan surafces.  Processing includes
!                finding the lat/lon and height of each observation. .
!
! program history log:
!   2011-08-12  carley - fix ob error to 2 m/s
!   2011-08-23  carley - use deter_sfc_mod
!   2011-12-08  carley - add wind rotation (earth to grid)
!
!   input argument list:
!     infile   - file from which to read data
!     lunout   - unit to which to write data for further processing
!     obstype  - observation type to process
!
!   output argument list:
!     nread    - number of radar reflectivity observations read
!     ndata    - number of radar reflectivity observations retained for further processing
!     nodata   - number of radar reflectivity observations retained for further processing
!     sis      - satellite/instrument/sensor indicator
!
! Variable Definitions:
!
!  a43 - real - (4/3)*(earth radius)
!  a,b,c,ha,epsh,h,aactual - real - used in computing radar observation height
!  cdata_all - real - dim(maxdat,maxobs) - array holding all data for assimilation
!  celev0,selev0 - real- cos and sin of elevation angle (raw)
!  celev,selev - real - corrected cos and sin of elevation angle
!  clat0 - real - cos of radar station latitude
!  cstaid - char - radar station ide
!  dbzerr - real - observation error (obtained from convinfo - dBZ)
!  dlat - real - grid relative latitude of observation (grid units)
!  dlon - real - grid relative longitude of observation (grid units)
!  gamma - real - used in finding observation latlon
!  lunrad - int - unit number for reading radar data from file
!  maxobs - int - max number of obs converted to no precip observations
!  num_m2nopcp -int - number of missing obs
!  num_missing - int - number of missing observations
!  num_noise - int - number of rejected noise observations
!  num_nopcp - int - number of noise obs converted to no precip observations
!  numbadtime - int - number of elevations outside time window
!  num_badtilt - int - number of elevations outside specified interval
!  num_badrange - int - number of obs outside specified range distance
!  obdate - int - dim(5) - yyyy,mm,dd,hh,minmin of observation
!  outside - logical - if observations are outside the domain -> true
!  radartwindow - real - time window for radar observations (minutes)
!  rlatglob - real - earth relative latitude of observation (radians)
!  rlatloc - real - latitude of observation on radar-relative projection
!  rlonglob - real - earth relative longitude of observation (radians)
!  rlonloc - real - longitude of observation on radar-relative projection
!  rlon0 - real - radar station longitude (radians)
!  rmins_an - real - analysis time from reference date (minutes)
!  rmins_ob - real -  observation time from reference date (minutes)
!  rstation_id - real - radar station id
!  slat0 - real - sin of radar station latitude
!  thisazimuthr - real - 90deg minues the actual azimuth and converted to radians
!  thiserr - real - observation error
!  thislat - real - latitude of observation
!  thislon - real - longitude of observation
!  thisrange - real - range of observation from radar
!  thishgt - real - observation height
!  this_stahgt - real - radar station height (meters about sea level)
!  this_staid - char - radar station id
!  thistilt - real - radar tilt angle (degrees)
!  thistiltr - real- radar tilt angle (radians)
!  timeb - real - obs time (analyis relative minutes)
!
!
!
! Derived data types
!
!  radar - derived data type for containing volume scan information
!     nelv- int - number of elevation angles
!     radid - char*4 - radar ID (e.g. KAMA)
!     vcpnum - int - volume coverage pattern number
!     year - int - UTC
!     day - int - UTC
!     month - int - UTC
!     hour - in - UTC
!     minute - int - UTC
!     second - int - UTC
!     radhgt - real - elevation of the radar above sea level in meters (I believe
!              this includes the height of the antenna as well)
!     radlat - real - latitude location of the radar
!     radlon - real - longitude location of the radar
!     fstgatdis - real - first gate distance (meters)
!     gatewidth - real - gate width (meters)
!     elev_angle - real - radar elevation angle (degrees)
!     num_beam - int - number of beams
!     num_gate - int - number of gates
!     nyq_vel - real - nyquist velocity
!     azim - real - azimuth angles
!     field - real - radar data variable (reflectivity or velocity)
!
! Defined radar types:
!  strct_in_vel - radar - contains volume scan information related to
!                         radial velocity
!  strct_in_dbz - radar - contains volume scan information related to
!                         radar reflectivity
!  strct_in_rawvel - radar - contains volume scan information related to
!                            raw radial velocity
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$ end documentation block

  use kinds, only: r_kind,r_double,i_kind
  use constants, only: zero,half,one,two,deg2rad,rearth,rad2deg, &
                       one_tenth,r1000,r60,r60inv,r100,r400,grav_equator, &
                        eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening
  use gridmod, only: regional,tll2xy,rotate_wind_ll2xy,nsig,nlat,nlon
  use obsmod, only: iadate, &
    mintiltvr,maxtiltvr,minobrangevr,maxobrangevr, rmesh_vr,zmesh_vr,&
    doradaroneob,oneoblat,oneoblon,oneobheight,oneobradid
  use obsmod,only: radar_no_thinning
  use gsi_4dvar, only: l4dvar,time_4dvar
  use convinfo, only: nconvtype,ctwind,icuse,ioctype
  use convthin, only: make3grids,map3grids,del3grids,use_all
  use read_l2bufr_mod, only: invtllv
  use qcmod, only: erradar_inflate
  use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model
  use mpimod, only: npe

  implicit none

! Declare passed variables
  character(len=*),intent(in   ) :: obstype,infile
  character(len=*),intent(in   ) :: sis
  integer(i_kind) ,intent(in   ) :: lunout
  integer(i_kind) ,intent(inout) :: nread,ndata,nodata
  real(r_kind),dimension(nlat,nlon,nsig),intent(in):: hgtl_full
  integer(i_kind),dimension(npe) ,intent(inout) :: nobs

! Declare local parameters
  real(r_kind),parameter :: four_thirds = 4.0_r_kind / 3.0_r_kind
  real(r_kind),parameter :: r8     = 8.0_r_kind
  real(r_kind),parameter:: r6 = 6.0_r_kind
  real(r_kind),parameter:: r360=360.0_r_kind
  integer(i_kind),parameter:: maxdat=22         ! Used in generating cdata array

!--Derived data type declaration

  type :: radar
     character(4) :: radid
     integer(i_kind) :: vcpnum
     integer(i_kind) :: year
     integer(i_kind) :: month
     integer(i_kind) :: day
     integer(i_kind) :: hour
     integer(i_kind) :: minute
     integer(i_kind) :: second
     real(r_kind) :: radlat
     real(r_kind) :: radlon
     real(r_kind) :: radhgt
     real(r_kind) :: fstgatdis
     real(r_kind) :: gateWidth
     real(r_kind) :: elev_angle
     integer(i_kind) :: num_beam
     integer(i_kind) :: num_gate
     real(r_kind) :: nyq_vel
     real(r_kind),allocatable :: azim(:)      !has dimension (num_beam)
     real(r_kind),allocatable :: field(:,:)   !has dimension (num_gate,num_beam)
  end type radar

!--Counters for diagnostics
 integer(i_kind) :: num_missing=0,numbadtime=0, &   !counts
                    num_badtilt=0,num_badrange=0, &
                    ibadazm=0

integer(i_kind) :: ithin,zflag,nlevz,icntpnt,klon1,klat1,kk,klatp1,klonp1
real(r_kind) :: rmesh,xmesh,zmesh,dx,dy,dx1,dy1,w00,w01,w10,w11
real(r_kind), allocatable, dimension(:) :: zl_thin
  real(r_kind),dimension(nsig):: hges,zges
  real(r_kind) sin2,termg,termr,termrg,zobs,height
  integer(i_kind) ntmp,iout,iiout,ntdrvr_thin2
  real(r_kind) crit1,timedif
  real(r_kind),parameter:: r16000 = 16000.0_r_kind
logical :: luse
  integer(i_kind) maxout,maxdata
  integer(i_kind),allocatable,dimension(:):: isort

!--General declarations
  integer(i_kind) :: ierror,lunrad,i,j,k,v,na,nb,nelv,nvol, &
                     ikx,mins_an,mins_ob
  integer(i_kind) :: maxobs,nchanl,ilat,ilon,idomsfc

  integer(i_kind),dimension(5) :: obdate

  real(r_kind) :: b,c,ha,epsh,h,aactual,a43,thistilt,ff10,sfcr,skint,zsges, &
                  radar_lon,radar_lat,dlon_radar,dlat_radar,errmax,errmin,error
  real(r_kind) :: thistiltr,selev0,celev0,thisrange,this_stahgt,thishgt
  real(r_kind) :: celev,selev,gamma,thisazimuthr,rlon0,t4dv, &
                  clat0,slat0,dlat,dlon,thiserr,thislon,thislat, &
		  rlonloc,rlatloc,rlonglob,rlatglob,timeb,rad_per_meter
  real(r_kind) :: azm,cosazm_earth,sinazm_earth,cosazm,sinazm
  real(r_kind) :: radartwindow
  real(r_kind) :: rmins_an,rmins_ob
  real(r_kind),allocatable,dimension(:,:):: cdata_all
  real(r_double) rstation_id

  character(8) cstaid
  character(4) this_staid
  equivalence (this_staid,cstaid)
  equivalence (cstaid,rstation_id)

  logical      :: outside

  type(radar),allocatable :: strct_in_vel(:,:)

real(r_kind) :: mintilt,maxtilt,maxobrange,minobrange

  integer(i_kind) :: thin_freq=1

  mintilt=mintiltvr
  maxtilt=maxtiltvr
  minobrange=minobrangevr
  maxobrange=maxobrangevr

  !-Check if radial velocity is in the convinfo file and extract necessary attributes

 ithin=1 !number of obs to keep per grid box
 if(radar_no_thinning) then
   ithin=-1
 endif

  errmax=-huge(errmax)
  errmin=huge(errmin)

  ikx=0
  do i=1,nconvtype
     if(trim(obstype) == trim(ioctype(i)) .and. abs(icuse(i))== 1) then
        ikx=i
        radartwindow=ctwind(ikx)*r60         !Time window units converted to minutes
	                                     !  (default setting for dbz within convinfo is 0.05 hours)
	thiserr= 2_r_kind !1.75_r_kind !2_r_kind                     !Ob error (m/s) to use for radial velocity
	exit                                 !Exit loop when finished with initial convinfo fields
     else if ( i==nconvtype ) then
        write(6,*) 'READ_RADAR_WIND_ASCII: ERROR - OBSERVATION TYPE IS NOT PRESENT IN CONVINFO OR USE FLAG IS ZERO'
	write(6,*) 'READ_RADAR_WIND_ASCII: ABORTING read_radar_wind_ascii.f90 - NO VELOCITY OBS READ!'
	return
     endif
  end do

  if (minobrange >= maxobrange) then
    write(6,*) 'MININMUM OB RANGE >= MAXIMUM OB RANGE FOR READING RADIAL VELOCITY - PROGRAM STOPPING FROM READ_RADAR_WIND_ASCII.F90'
    call stop2(400)
  end if

  !-next three values are dummy values for now
  nchanl=0
  ilon=2
  ilat=3

  maxobs=50000000    !value taken from read_radar.f90

  !--Allocate cdata_all array

  allocate(cdata_all(maxdat,maxobs),isort(maxobs))

  rmesh=rmesh_vr
  zmesh=zmesh_vr

  maxout=0
  maxdata=0
  isort=0
  ntdrvr_thin2=0
  icntpnt=0
  zflag=0

  use_all=.true.
  if (ithin > 0) then
     write(6,*)'READ_RADAR: ithin,rmesh :',ithin,rmesh
     use_all=.false.
     if(zflag == 0)then
        nlevz=nsig
     else
        nlevz=r16000/zmesh
     endif
     xmesh=rmesh
     call make3grids(xmesh,nlevz)

     allocate(zl_thin(nlevz))
     if (zflag == 1) then
        do k=1,nlevz
           zl_thin(k)=k*zmesh
        enddo
     endif
     write(6,*)'READ_RADAR: xmesh, zflag, nlevz =', xmesh, zflag, nlevz
  endif

  lunrad=31
  open(lunrad,file=trim(infile),status='old',action='read', &
       iostat=ierror,form='formatted')

 fileopen: if (ierror == 0) then
  read(lunrad,'(2i8)') nelv,nvol               !read number of elevations and number of volumes

     !*************************IMPORTANT***************************!
     !                                                             !
     !    All data = 999.0 correspond to missing or bad data       !
     !                                                             !
     !*************************************************************!

 !------Begin processing--------------------------!

 !-Obtain analysis time in minutes since reference date

  call w3fs21(iadate,mins_an)  !mins_an -integer number of mins snce 01/01/1978
  rmins_an=mins_an             !convert to real number

  volumes: do v=1,nvol

    read(lunrad,'(i8)') nelv
    allocate(strct_in_vel(1,nelv))
    tilts: do k=1,nelv

         read(lunrad,'(a4)') strct_in_vel(1,k)%radid
        read(lunrad,'(i8)') strct_in_vel(1,k)%vcpnum
        read(lunrad,'(6i8)') strct_in_vel(1,k)%year              &
                         ,strct_in_vel(1,k)%month                &
                         ,strct_in_vel(1,k)%day                  &
                         ,strct_in_vel(1,k)%hour                 &
                         ,strct_in_vel(1,k)%minute               &
                         ,strct_in_vel(1,k)%second
        read(lunrad,'(2f10.3,f10.1)') strct_in_vel(1,k)%radlat   &
                                  ,strct_in_vel(1,k)%radlon      &
                                  ,strct_in_vel(1,k)%radhgt
        read(lunrad,'(2f8.1)') strct_in_vel(1,k)%fstgatdis       &
                           ,strct_in_vel(1,k)%gateWidth
        read(lunrad,'(f8.3)') strct_in_vel(1,k)%elev_angle
        read(lunrad,'(2i8)') strct_in_vel(1,k)%num_beam          &
                         ,strct_in_vel(1,k)%num_gate
        na=strct_in_vel(1,k)%num_beam
        nb=strct_in_vel(1,k)%num_gate

        !******allocate arrays within radar data type**********!
           allocate(strct_in_vel(1,k)%azim(na))
           allocate(strct_in_vel(1,k)%field(nb,na))
        !******************************************************!

        read(lunrad,'(f8.3)') strct_in_vel(1,k)%nyq_vel
        read(lunrad,'(15f6.1)') (strct_in_vel(1,k)%azim(j),j=1,na)
        read(lunrad,'(20f6.1)') ((strct_in_vel(1,k)%field(i,j),i=1,nb),j=1,na)

        obdate(1)=strct_in_vel(1,k)%year
        obdate(2)=strct_in_vel(1,k)%month
        obdate(3)=strct_in_vel(1,k)%day
        obdate(4)=strct_in_vel(1,k)%hour
        obdate(5)=strct_in_vel(1,k)%minute
        call w3fs21(obdate,mins_ob)                             !mins_ob -integer number of mins snce 01/01/1978
	rmins_ob=mins_ob                                        !convert to real number
	rmins_ob=rmins_ob+(strct_in_vel(1,k)%second*r60inv)     !convert seconds to minutes and add to ob time

      !-Comparison is done in units of minutes

        timeb = rmins_ob-rmins_an

        if(doradaroneob .and. (oneobradid /= strct_in_vel(1,k)%radid)) cycle tilts

        if(abs(timeb) > abs(radartwindow)) then
	  numbadtime=numbadtime+1
	  cycle tilts                           !If not in time window, cycle the loop
	end if
      !--Time window check complete--!

        thistilt=strct_in_vel(1,k)%elev_angle
        if (thistilt <= maxtilt .and. thistilt >= mintilt) then

          gates: do i=1,strct_in_vel(1,k)%num_gate,thin_freq
   	      thisrange=strct_in_vel(1,k)%fstgatdis + float(i-1)*strct_in_vel(1,k)%gateWidth

             !-Check to make sure observations are within specified range

              if (thisrange <= maxobrange .and. thisrange >= minobrange) then

	      azms: do j=1,strct_in_vel(1,k)%num_beam

	           !-Check to see if this is a missing observation)
		    nread=nread+1
		    if ( strct_in_vel(1,k)%field(i,j) >= 999.0_r_kind ) then
			  num_missing=num_missing+1
	  	          cycle azms                        !No reason to process the ob if it is missing
                    end if

		   !--Find observation height using method from read_l2bufr_mod.f90

		    this_stahgt=strct_in_vel(1,k)%radhgt
                    aactual=rearth+this_stahgt
                    a43=four_thirds*aactual
                    thistiltr=thistilt*deg2rad
                    selev0=sin(thistiltr)
                    celev0=cos(thistiltr)
		    b=thisrange*(thisrange+two*aactual*selev0)
                    c=sqrt(aactual*aactual+b)
                    ha=b/(aactual+c)
                    epsh=(thisrange*thisrange-ha*ha)/(r8*aactual)
                    h=ha-epsh
	            thishgt=this_stahgt+h
                    height=thishgt
		   !--Find observation location using method from read_l2bufr_mod.f90

		   !-Get corrected tilt angle
	            celev=celev0
	            selev=selev0
           	    celev=a43*celev0/(a43+h)
		    selev=(thisrange*thisrange+h*h+two*a43*h)/(two*thisrange*(a43+h))

		    gamma=half*thisrange*(celev0+celev)

                   !-Get earth lat lon of observation

                    rlon0=deg2rad*strct_in_vel(1,k)%radlon
	       	    clat0=cos(deg2rad*strct_in_vel(1,k)%radlat)
		    slat0=sin(deg2rad*strct_in_vel(1,k)%radlat)
		    thisazimuthr=(90.0_r_kind-strct_in_vel(1,k)%azim(j))*deg2rad   !Storing as 90-azm to
		                                                                   ! be consistent with
										   ! read_l2bufr_mod.f90
		    rad_per_meter=one/rearth
		    rlonloc=rad_per_meter*gamma*cos(thisazimuthr)
                    rlatloc=rad_per_meter*gamma*sin(thisazimuthr)

		    call invtllv(rlonloc,rlatloc,rlon0,clat0,slat0,rlonglob,rlatglob)

		    thislat=rlatglob*rad2deg
                    thislon=rlonglob*rad2deg

                    if(doradaroneob) then
                      thislat=oneoblat
                      thislon=oneoblon
                      thishgt=oneobheight
                     endif

		    if(thislon>=r360) thislon=thislon-r360
                    if(thislon<zero ) thislon=thislon+r360

		   !-Convert back to radians

		    thislat = thislat*deg2rad
                    thislon = thislon*deg2rad

		    !find grid relative lat lon locations of earth lat lon

		    call tll2xy(thislon,thislat,dlon,dlat,outside)
                    if (outside) cycle azms             !If observation is outside the domain
		                                        ! then cycle, but don't increase range right away.
							! Domain could be rectangular, so ob may be out of
						        ! range at one end, but not the other.

                   if(regional) then
                       cosazm_earth=cos(thisazimuthr)
                       sinazm_earth=sin(thisazimuthr)
                       call rotate_wind_ll2xy(cosazm_earth,sinazm_earth,cosazm,sinazm,thislon,dlon,dlat)
                       azm=atan2(sinazm,cosazm)
                    else
                       azm=thisazimuthr
                    end if

		   !--Do limited QC from read_radar.f90--!
	            error = erradar_inflate*thiserr
                    errmax=max(error,errmax)
                    if(thiserr>zero) errmin=min(error,errmin)
                    if(abs(azm)>r400) then
                       ibadazm=ibadazm+1
                       cycle azms
                    end if

		    this_staid=strct_in_vel(1,k)%radid      !Via equivalence in declaration, value is propagated
		    					    !  to rstation_id used below.

		    ! Get model terrain at radar station location
		    ! If radar station is outside of grid, does not mean the
		    !    radar obs are outside the grid - therefore no need to
		    !    cycle azms.

		    radar_lon=deg2rad*strct_in_vel(1,k)%radlon
		    radar_lat=deg2rad*strct_in_vel(1,k)%radlat
		    call tll2xy(radar_lon,radar_lat,dlon_radar,dlat_radar,outside)
                    call deter_zsfc_model(dlat_radar,dlon_radar,zsges)

		    !  Determines land surface type based on surrounding land
                    !    surface types

		    t4dv=timeb*r60inv

	            call deter_sfc2(thislat,thislon,t4dv,idomsfc,skint,ff10,sfcr)

!####################       Data thinning       ###################

           icntpnt=icntpnt+1

           if(ithin > 0)then
              if(zflag == 0)then
                 klon1= int(dlon);  klat1= int(dlat)
                 dx   = dlon-klon1; dy   = dlat-klat1
                 dx1  = one-dx;     dy1  = one-dy
                 w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy

                 klat1=min(max(1,klat1),nlat); klon1=min(max(0,klon1),nlon)
                 if (klon1==0) klon1=nlon
                 klatp1=min(nlat,klat1+1); klonp1=klon1+1
                 if (klonp1==nlon+1) klonp1=1
                 do kk=1,nsig
                    hges(kk)=w00*hgtl_full(klat1 ,klon1 ,kk) +  &
                             w10*hgtl_full(klatp1,klon1 ,kk) + &
                             w01*hgtl_full(klat1 ,klonp1,kk) + &
                             w11*hgtl_full(klatp1,klonp1,kk)
                 end do
                 sin2  = sin(thislat)*sin(thislat)
                 termg = grav_equator * &
                    ((one+somigliana*sin2)/sqrt(one-eccentricity*eccentricity*sin2))
                 termr = semi_major_axis /(one + flattening + grav_ratio -  &
                    two*flattening*sin2)
                 termrg = (termg/grav)*termr
                 do kk=1,nsig
                    zges(kk) = (termr*hges(kk)) / (termrg-hges(kk))
                    zl_thin(kk)=zges(kk)
                 end do
              endif

              zobs = height

              ntmp=ndata  ! counting moved to map3gridS
              if (l4dvar) then
                 timedif = zero
              else
!                 timedif=abs(t4dv-toff)
                 timedif=abs(t4dv) !don't know about this
              endif
              crit1 = timedif/r6+half

              call map3grids(1,zflag,zl_thin,nlevz,thislat,thislon,&
                 zobs,crit1,ndata,iout,icntpnt,iiout,luse, .false., .false.)
              maxout=max(maxout,iout)
              maxdata=max(maxdata,ndata)

              if (.not. luse) then
                 ntdrvr_thin2=ntdrvr_thin2+1
                 cycle
              endif
              if(iiout > 0) isort(iiout)=0
              if (ndata > ntmp) then
                 nodata=nodata+1
              endif
              isort(icntpnt)=iout

           else
              ndata =ndata+1
              nodata=nodata+1
              iout=ndata
              isort(icntpnt)=iout
           endif

		    cdata_all(1,iout) = error		                 ! wind obs error (m/s)
		    cdata_all(2,iout) = dlon		                 ! grid relative longitude
	            cdata_all(3,iout) = dlat 	                         ! grid relative latitude
	     	    cdata_all(4,iout) = thishgt	                 ! obs absolute height (m)
	     	    cdata_all(5,iout) = strct_in_vel(1,k)%field(i,j)    ! wind obs (m/s)
	     	    cdata_all(6,iout) = azm                             ! azimuth angle (radians)
	            cdata_all(7,iout) = t4dv       		         ! obs time (hour) - analysis relative
	            cdata_all(8,iout) = ikx		                 ! type
	            cdata_all(9,iout) = thistiltr	                 ! tilt angle (radians)
	            cdata_all(10,iout)= this_stahgt	                 ! station elevation (m)
	            cdata_all(11,iout)= rstation_id	                 ! station id
	            cdata_all(12,iout)= icuse(ikx)		         ! usage parameter
	            cdata_all(13,iout)= idomsfc  	                 ! dominate surface type
	            cdata_all(14,iout)= skint		                 ! skin temperature
	            cdata_all(15,iout)= ff10		                 ! 10 meter wind factor
	            cdata_all(16,iout)= sfcr		                 ! surface roughness
	            cdata_all(17,iout)=thislon*rad2deg                  ! earth relative longitude (degrees)
	            cdata_all(18,iout)=thislat*rad2deg                  ! earth relative latitude (degrees)
	            cdata_all(19,iout)=thisrange/1000_r_kind		 ! range from radar in km (used to estimate beam spread)
	            cdata_all(20,iout)=zsges		                 ! model elevation at radar site
	            cdata_all(21,iout)=thiserr
	            cdata_all(22,iout)=two                              ! Level 2 data

                if(doradaroneob .and. (cdata_all(5,iout) > -99_r_kind) ) exit volumes

                end do azms  !j
              else
	         num_badrange=num_badrange+1      !If outside acceptable range, increment
	      end if   !Range check

	   end do gates    !i

        else
           num_badtilt=num_badtilt+1           !If outside acceptable tilts, increment
        end if         !Tilt check

     end do tilts       !k

     do k=1,nelv
        deallocate(strct_in_vel(1,k)%azim)
        deallocate(strct_in_vel(1,k)%field)
     enddo
     deallocate(strct_in_vel)
  end do volumes      !v

  close(lunrad) !modified to do one scan at a time

  if (.not. use_all) then
     deallocate(zl_thin)
     call del3grids
  endif
!end modified for thinning

!---all looping done now print diagnostic output

  write(6,*)'READ_RADAR_WIND_ASCII: Reached eof on radar wind ascii file'
  write(6,*)'READ_RADAR_WIND_ASCII: # volumes in input file             =',nvol
  write(6,*)'READ_RADAR_WIND_ASCII: # elevations per volume             =',nelv
  write(6,*)'READ_RADAR_WIND_ASCII: # elevations outside time window    =',numbadtime
  write(6,*)'READ_RADAR_WIND_ASCII: # of missing data                   =',num_missing
  write(6,*)'READ_RADAR_WIND_ASCII: # outside specif. range             =',num_badrange
  write(6,*)'READ_RADAR_WIND_ASCII: # outside specif. tilts             =',num_badtilt
  write(6,*)'READ_RADAR_WIND_ASCII: # bad azimuths                      =',ibadazm
!---Write observation to scratch file---!

  call count_obs(ndata,maxdat,ilat,ilon,cdata_all,nobs)
  write(lunout) obstype,sis,maxdat,nchanl,ilat,ilon
  write(lunout) ((cdata_all(k,i),k=1,maxdat),i=1,ndata)

  !---------------DEALLOCATE ARRAYS-------------!

  deallocate(cdata_all)

 else  !fileopen
  write(6,*) 'READ_RADAR_WIND_ASCII: ERROR OPENING RADIAL VELOCITY FILE: ',trim(infile),' IOSTAT ERROR: ',ierror, ' SKIPPING...'
 end if fileopen

end subroutine read_radar_wind_ascii


      SUBROUTINE ML5_0_MP_HELAS_CALLS_UVCT_1(P,NHEL,H,IC)
C
      USE ML5_0_POLYNOMIAL_CONSTANTS
      IMPLICIT NONE
C
C     CONSTANTS
C
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=5)
      INTEGER    NCOMB
      PARAMETER (NCOMB=32)

      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=2)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=11, NLOOPGROUPS=9, NCTAMPS=28)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=39)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=10,NLOOPWAVEFUNCS=27)
      REAL*16     ZERO
      PARAMETER (ZERO=0.0E0_16)
      COMPLEX*32     IZERO
      PARAMETER (IZERO=CMPLX(0.0E0_16,0.0E0_16,KIND=16))
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=0, NSQUAREDSO=0, NAMPSO=0)
C
C     ARGUMENTS
C
      REAL*16 P(0:3,NEXTERNAL)
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      INTEGER H
C
C     LOCAL VARIABLES
C
      INTEGER I,J,K
      COMPLEX*32 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)
C
C     GLOBAL VARIABLES
C
      INCLUDE 'mp_coupl_same_name.inc'

      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_FILTERS/GOODAMP,GOODHEL

      INTEGER SQSO_TARGET
      COMMON/ML5_0_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/ML5_0_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE
     $ ,MP_LOOP_REQ_SO_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      COMPLEX*32 AMP(NBORNAMPS)
      COMMON/ML5_0_MP_AMPS/AMP
      COMPLEX*32 W(20,NWAVEFUNCS)
      COMMON/ML5_0_MP_W/W

      COMPLEX*32 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE
     $ ,0:NLOOPWAVEFUNCS)
      COMPLEX*32 PL(0:3,0:NLOOPWAVEFUNCS)
      COMMON/ML5_0_MP_WL/WL,PL

      COMPLEX*32 AMPL(3,NCTAMPS)
      COMMON/ML5_0_MP_AMPL/AMPL

C
C     ----------
C     BEGIN CODE
C     ----------

C     The target squared split order contribution is already reached
C      if true.
      IF (FILTER_SO.AND.MP_UVCT_REQ_SO_DONE) THEN
        GOTO 1001
      ENDIF

C     Amplitude(s) for UVCT diagram with ID 14
      CALL MP_FFV2_0(W(1,6),W(1,2),W(1,7),GC_47,AMPL(1,25))
      AMPL(1,25)=AMPL(1,25)*(1.0D0*UVWFCT_G_2+1.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 15
      CALL MP_FFV2_0(W(1,6),W(1,2),W(1,7),GC_47,AMPL(2,26))
      AMPL(2,26)=AMPL(2,26)*(2.0D0*UVWFCT_G_2_1EPS)
C     Amplitude(s) for UVCT diagram with ID 16
      CALL MP_FFV2_0(W(1,1),W(1,8),W(1,7),GC_47,AMPL(1,27))
      AMPL(1,27)=AMPL(1,27)*(1.0D0*UVWFCT_G_2+1.0D0*UVWFCT_G_1)
C     Amplitude(s) for UVCT diagram with ID 17
      CALL MP_FFV2_0(W(1,1),W(1,8),W(1,7),GC_47,AMPL(2,28))
      AMPL(2,28)=AMPL(2,28)*(2.0D0*UVWFCT_G_2_1EPS)

      GOTO 1001
 3000 CONTINUE
      MP_UVCT_REQ_SO_DONE=.TRUE.
 1001 CONTINUE
      END


C @(#)chorec.for	15.1.1.1 (ES0-DMD) 01/12/01 16:57:08
C===========================================================================
C Copyright (C) 1995 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or
C modify it under the terms of the GNU General Public License as
C published by the Free Software Foundation; either version 2 of
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public
C License along with this program; if not, write to the Free
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge,
C MA 02139, USA.
C
C Corresponding concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen
C			GERMANY
C===========================================================================
C
      SUBROUTINE CHOREC(A,N,NDIM,ISTAT)
*
*  Module number:
*
*  Module name: CHOREC
*
*  Keyphrase:
*  ----------
*       perform inversion
*
*  Description:
*  ------------
*
*  FORTRAN name: chorec.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*
*
*  Subroutines Called:
*  -------------------
*
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       Nov 01  A. Alexov       Copy of chorec.for from midas
*-----------------------------------------------------------------------------
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C.COPYRIGHT: Copyright (c) 1987 European Southern Observatory,
C                                         all rights reserved
C
C.VERSION: 1.0  ESO-FORTRAN Conversion, AA  17:25 - 13 JAN 1988
C
C.LANGUAGE: F77+ESOext
C
C.AUTHOR: J.D.PONZ
C
C.IDENTIFICATION
C
C  FITLIB.FOR   VERSION 1.0  27 MAR 1984
C
C.PURPOSE
C
C  INTERFACE ROUTINES FOR THE FITTING STRUCTURES
C
C.ALGORITHM
C
C  USE MIDAS I/O INTERFACES TO FRAMES AND TABLES
C
C.KEYWORDS
C
C  NON LINEAR FITTING
C
C
C----------------------------------------------------------------
C
C INVERSION OF A SYMMETRIC POSITIVE MATRIX
C      IMPLICIT NONE
C USING THE CHOLESKY ALGORITHM
C
C INPUT PARAMS
C A DBLE INPUT MATRIX
C N INTG ACTUAL MATRIX RANGE
C NDIM INTG TRUE DIMENSION IN MATRIX
C
C OUTPUT PARAMS
C ISTAT INTG 0 - NO ERROR
C
C THE MATRIX IS INVERTED IN-PLACE
C
C
      INTEGER NDIM,N,ISTAT,I,J,K,KK
      DOUBLE PRECISION A(NDIM,NDIM)
C
      DOUBLE PRECISION P,Q,H(400)
C REAL*8 X,Y,Z
C
      ISTAT  = 0
      IF (N.GT.NDIM) GO TO 70
C
C MATRIX INVERSION USING THE GAUSS-JORDAN METHOD
C  MODIFIED VERSION BY F.L. BAUER AND C. REINSCH
C
      DO 40 K = 1,N
          IF (A(1,1).LE.0.0D0) THEN
              ISTAT  = 1
              GO TO 70

          END IF

          KK     = N + 1 - K
          P      = 1.0D0/A(1,1)
          DO 20 I = 2,N
              Q      = A(I,1)
              H(I)   = Q*P
              IF (I.LE.KK) H(I)   = -H(I)
              DO 10 J = 2,I
                  A(I-1,J-1) = A(I,J) + Q*H(J)
   10         CONTINUE
   20     CONTINUE
          A(N,N) = P
          DO 30 I = 2,N
              A(N,I-1) = H(I)
   30     CONTINUE
   40 CONTINUE
      DO 60 I = 2,N
          DO 50 J = 1,I
              A(J,I) = A(I,J)
   50     CONTINUE
   60 CONTINUE
C
C  ... Routine below does not work !
C
C DO I = 1,N
C   DO J = I,N
C     X = A(I,J)
C     IF (I.NE.1) THEN
C       DO K = 1,I-1
C         X = X-A(J+1,I-K)*A(I+1,I-K)
C       ENDDO
C     ENDIF
C     IF (I.NE.J) THEN
C       A(J+1,I) = X*Y
C     ELSE
C       IF (X.LE.0.0D0) THEN
C  ISTAT = 1
C  GO TO 1000
C       ENDIF
C       Y = 1.0D0/DSQRT(X)
C       A(I+1,I) = Y
C     ENDIF
C   ENDDO
C ENDDO
C DO I = 2,N
C   DO J = I,N
C     Z = 0.0D0
C     DO K = I,J-1
C       Z = Z-A(J+1,K)*A(K+1,I-1)
C     ENDDO
C     A(J+1,I-1) = Z*A(J+1,J)
C   ENDDO
C ENDDO
C DO I = 1,N
C   DO J = I,N
C     Z = 0.0D0
C     DO K = J,N
C       Z = Z+A(K+1,J)*A(K+1,I)
C     ENDDO
C     A(J+1,I) = Z
C   ENDDO
C ENDDO
C DO I = 2,N
C   DO J = I,N
C     A(I-1,J) = A(J,I-1)
C   ENDDO
C ENDDO
      RETURN

   70 ISTAT  = ISTAT + 1
      RETURN

      END


      program L1L1elect
      implicit double precision(a-h,o-z)

c reads in the cat OUT_L1L1_data file which contains lines like
c       k1     k2    nsign
c where k1 and k2 identify the L1 fragments that will be
c interacted electrostatically
c nsign is the sign coefficient

c We will read OUT_L1L1_data one line at a time
c we will open the
c nb.k1.0.cart
c nb.k2.0.cart
c files, and read in the multipole moments etc
c Then we simply call the elect subroutine to evalaute the
c multipole-multipole interactions

      real*8, allocatable    ::ch1(:,:),c1(:,:,:),d1(:,:,:),q1(:,:,:,:)
      real*8, allocatable    ::del1(:,:),del2(:,:)
      real*8, allocatable    ::secd1(:,:,:,:),secd2(:,:,:,:),
     .                         secd3(:,:,:,:)

      character*20 ca, ca1

      integer, allocatable  ::nat0(:)
      integer, allocatable  ::numchggrps(:)
      real*8, allocatable   ::c0(:,:,:)
      integer, allocatable  ::numat(:),natstore(:,:)
      character*2, lab0

      real*8, allocatable   :: g(:,:),h(:,:),w1(:,:,:)
      integer, allocatable   :: nat1(:),num1(:,:),natnum1(:,:,:)

      dimension totk(3)

      Bohr=1.88972598860

c     integer, allocatable   :: num(:),natnum(:,:)
c     real*8, allocatable   :: w(:,:)

c get the jobtype
      open(unit=1,file='IN_JOBTYPE',status='old')
      read(1,*)
      read(1,*)jobtype
      close(unit=1)

c the IN_COMBINE file specifies whether electrostatic forces are
c used
c     open(unit=1,file='IN_COMBINE',status='old')
c     read(1,*)
c     read(1,*)nforce
c     close(unit=1)
c DO NOT USE GRADIENTS
c     if(nforce.lt.3)jobtype=0

      tote=0

      numcharges=0
c we will need to know which groups contain charges
      open(unit=1,file='OUT_CHARGEDGROUPS',status='unknown')
      read(1,*,end=333)
      read(1,*)numcharges
      if(numcharges.gt.0)then
       allocate(numchggrps(numcharges))
       read(1,*)
       do k=1,numcharges
        read(1,*)numchggrps(k)
        read(1,*)
        read(1,*)
        read(1,*)
       enddo
      endif
333   continue
      close(unit=1)

c we need the number of groups
      open(unit=1,file='frags.out_Lev0',status='old')
      read(1,*)
      read(1,*)ngroups
      allocate(nat0(ngroups))
      allocate(c0(ngroups,60,3))
      close(unit=1)
c if there are charges, we will need the coordinates of the groups
c which contain charges

c read in the Level 0 (group) coordinates
      do n=1,ngroups
       call filelabel(n,ca)
       ca1='Lev0_COORD'//ca
       open(unit=1,file=ca1,status='old')
       read(1,*)
       m=1
15     continue
       read(1,*,end=25)lab0,(c0(n,m,k),k=1,3)
       m=m+1
       go to 15
25     continue
       nat0(n)=m-1
       close(unit=1)
      enddo
100   format(a2,3f13.6)
c we will need the L1 fragment group numbers
      open(unit=8,file='OUT_FINAL_L1_DATA',status='unknown')
      read(8,*)
      read(8,*)
      read(8,*)nL1frags
      allocate(numat(nL1frags))
      allocate(natstore(nL1frags,8))

      read(8,*)
      do n=1,nL1frags
       read(8,*)n1,numat(n)
       read(8,*)(natstore(n,j),j=1,numat(n))
      enddo
      close(unit=8)

c if jobtype > 0, we need data to allocate gradients and
c second derivatives
      if(jobtype.gt.0)then
c get the number of atoms
       open(unit=1,file='name.xyz',status='old')
       read(1,*)natom
       close(unit=1)

       allocate(g(natom,3))
       g=0
      endif
       if(jobtype.eq.2)then
        allocate(h(3*natom,3*natom))
c       allocate(num(natom))
c       allocate(natnum(natom,6))
c       allocate(w(natom,6))
        h=0
       endif

c get the Lev1 identities
       open(unit=1,file='OUT_Lev1_ATOMALLOCATION',status='old')
       read(1,*)
       read(1,*)NL1
       read(1,*)
       read(1,*)

       allocate(nat1(NL1))
       allocate(num1(NL1,200))
       allocate(natnum1(NL1,200,6))
       allocate(w1(NL1,200,6))

       do n=1,NL1
        read(1,*)i1,nat1(n)
        do m=1,nat1(n)
         read(1,*)num1(n,m),
     .           (natnum1(n,m,k),w1(n,m,k),k=1,num1(n,m))
        enddo
       enddo

       close(unit=1)

       do n=1,NL1
       do m=1,nat1(n)
        if(num1(n,m).eq.1)w1(n,m,1)=1.d0
        if(num1(n,m).eq.2)w1(n,m,2)=1.d0-w1(n,m,1)
       enddo
       enddo

c find max atoms in a level 1 fragment
      L1max=0
       do n=1,NL1
        if(nat1(n).gt.L1max)L1max=nat1(n)
       enddo

       allocate(ch1(NL1,L1max))
       allocate(c1(NL1,L1max,3))
       allocate(d1(NL1,L1max,3))
       allocate(q1(NL1,L1max,3,3))
c read in the multipoles
       do m=1,NL1
       call filelabel(m,ca1)
       n1=index(ca1,' ')-1
       ca='nb.'//ca1(1:n1)//'.0'//'.cart'
       open(unit=1,file=ca,status='old')
       read(1,*)
       read(1,*)natom1
        if(natom1.ne.nat1(m))then
         write(6,*)' problem with natom1 ',m,nat1(m),natom1
         stop
        endif
      do n=1,natom1
       read(1,*)
       do k=1,3
        read(1,*)c1(m,n,k)
       enddo
       read(1,*)
       read(1,*)ch1(m,n)
       read(1,*)
       do k=1,3
        read(1,*)d1(m,n,k)
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       read(1,*)q1(m,n,k1,k2)
       q1(m,n,k2,k1)=q1(m,n,k1,k2)
       enddo
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       do k3=k2,3
        read(1,*)
       enddo
       enddo
       enddo
       read(1,*)
       do k1=1,3
       do k2=k1,3
       do k3=k2,3
       do k4=k3,3
        read(1,*)
       enddo
       enddo
       enddo
       enddo

      enddo

      close(unit=1)
c if there are charges, we need to see if this L1 frag contains
c group with charges. The electrostatic interaction of charged
c groups will all other groups has already been done, so the
c moments of such groups must be set to zero
      if(numcharges.gt.0)then
       do k=1,numcharges
       do j=1,numat(m)
        if(numchggrps(k).eq.natstore(m,j))then
       call zero1(L1max,natom1,c1(m,:,:),ch1(m,:),d1(m,:,:),q1(m,:,:,:),
     .             nat0(natstore(m,j)),c0(natstore(m,j),:,:))
        endif
       enddo
       enddo
      endif
c convert coordinates to Bohr
      do n=1,nat1(m)
      do k=1,3
       c1(m,n,k)=c1(m,n,k)*Bohr
      enddo
      enddo

c close the m loop
      enddo

c now we read in the electrostatic interactions L1..L1, one at a time

      open(unit=2,file='OUT_L1L1_data',status='unknown')

c begin the line by line loop
1     continue
      read(2,*,end=2)m1,m2,nsign

c we use only up to quadrupoles for the fast code
c the multipole tensors do not have to be symmetrized

c simply call subroutine elect
c jobtype=0, energies only
c jobtype=1, also gradients
c jobtype=2 second derivatives

        allocate(del1(nat1(m1),3))
        allocate(del2(nat1(m2),3))
        allocate(secd1(nat1(m1),3,nat1(m1),3))
        allocate(secd2(nat1(m1),3,nat1(m2),3))
        allocate(secd3(nat1(m2),3,nat1(m2),3))

      call elect(L1max,nat1(m1),c1(m1,:,:),ch1(m1,:),d1(m1,:,:),
     .           q1(m1,:,:,:),
     .           nat1(m2),c1(m2,:,:),ch1(m2,:),d1(m2,:,:),q1(m2,:,:,:),
     .           elen,del1,del2,secd1,secd2,secd3,jobtype)

      tote=tote+elen*nsign

      if(jobtype.gt.0)then

c make the gradients sum to zero
      do k=1,3
       totk(k)=0.d0
      enddo

c allocate the gradients
       do k=1,3
       do m=1,nat1(m1)
        totk(k)=totk(k)+del1(m,k)
       do j=1,num1(m1,m)
        g(natnum1(m1,m,j),k)=g(natnum1(m1,m,j),k)+
     .                      del1(m,k)*w1(m1,m,j)*nsign
c       totk(k)=totk(k)+del1(m,k)*w1(m1,m,j)
       enddo
       enddo
       enddo

       do k=1,3
       do m=1,nat1(m2)
        totk(k)=totk(k)+del2(m,k)
       do j=1,num1(m2,m)
        g(natnum1(m2,m,j),k)=g(natnum1(m2,m,j),k)+
     .                      del2(m,k)*w1(m2,m,j)*nsign
c       totk(k)=totk(k)+del2(m,k)*w1(m2,m,j)
       enddo
       enddo
       enddo

c      write(34,*)(totk(k),k=1,3)
c end the jobtype if
      endif

      if(jobtype.eq.2)then

        do k1=1,3
        do k2=1,3
        do i1=1,nat1(m1)
c       do i2=1,natom1
        i2=i1
        do j1=1,num1(m1,i1)
        do j2=1,num1(m1,i2)
         l1=3*(natnum1(m1,i1,j1)-1)+k1
         l2=3*(natnum1(m1,i2,j2)-1)+k2
         h(l1,l2)=h(l1,l2)+secd1(i1,k1,i2,k2)*w1(m1,i1,j1)*
     .                     w1(m1,i2,j2)*nsign
        enddo
        enddo
c       enddo
        enddo
        enddo
        enddo

        do k1=1,3
        do k2=1,3
        do i1=1,nat1(m2)
c       do i2=1,natom2
        i2=i1
        do j1=1,num1(m2,i1)
        do j2=1,num1(m2,i2)
         l1=3*(natnum1(m2,i1,j1)-1)+k1
         l2=3*(natnum1(m2,i2,j2)-1)+k2
         h(l1,l2)=h(l1,l2)+secd3(i1,k1,i2,k2)*w1(m2,i1,j1)*
     .                     w1(m2,i2,j2)*nsign
        enddo
        enddo
c       enddo
        enddo
        enddo
        enddo

        do k1=1,3
        do k2=1,3
        do i1=1,nat1(m1)
        do i2=1,nat1(m2)
        do j1=1,num1(m1,i1)
        do j2=1,num1(m2,i2)
         l1=3*(natnum1(m1,i1,j1)-1)+k1
         l2=3*(natnum1(m2,i2,j2)-1)+k2
         h(l1,l2)=h(l1,l2)+secd2(i1,k1,i2,k2)*w1(m1,i1,j1)*
     .                     w1(m2,i2,j2)*nsign
         h(l2,l1)=h(l2,l1)+secd2(i1,k1,i2,k2)*w1(m1,i1,j1)*
     .                     w1(m2,i2,j2)*nsign
        enddo
        enddo
        enddo
        enddo
        enddo
        enddo

c end the jobtype=2 if
      endif

c deallocate the arrays
       deallocate(del1)
       deallocate(del2)
       deallocate(secd1)
       deallocate(secd2)
       deallocate(secd3)

      go to 1
2     continue
      close(unit=2)

c check sums
c      do n1=1,natom
c      do k1=1,3
c      do k2=1,3
c       sumk=0.d0
c       do n2=1,natom
c        i1=3*(n1-1)+k1
c        i2=3*(n2-1)+k2
c        sumk=sumk+h(i1,i2)
c       enddo
c       write(34,*)sumk
c      enddo
c      enddo
c      enddo

c output
      if(jobtype.gt.0)then

c remove centre of mass forces
      do k=1,3
       sumk=0.d0
       do n=1,natom
        sumk=sumk+g(n,k)
       enddo
c      write(6,*)sumk,natom
       sumk=sumk/dble(float(natom))
       do n=1,natom
        g(n,k)=g(n,k)-sumk
       enddo
      enddo

      endif

      open(unit=1,file='Electrostatic_derivs',status='unknown')
      write(1,*)tote
      write(1,*)jobtype
      if(jobtype.gt.0)then
      write(1,*)natom
      do n=1,natom
       write(1,*)(g(n,k),k=1,3)
      enddo
      endif
101   format(6f10.6)
      if(jobtype.eq.2)then
        n3=3*natom
        write(1,101)((h(i,j),j=1,i),i=1,n3)
c      do i=1,n3
c      do j=1,i
c       write(1,*)h(i,j)
c      enddo
c      enddo
      endif
      close(unit=1)

      end