      subroutine mcfm_vegas(myinit,myitmx,myncall,mybin,xinteg,xerr)
************************************************************************
*                                                                      *
*  This routine should perform the sweeps of vegasnr                   *
*                                                                      *
*    Input parameters:                                                 *
*       myinit  :  the vegasnr routine entry point                     *
*       myitmx  :  the number of vegasnr sweeps                        *
*      myncall  :  the number of iterations per sweep                  *
*          bin  :  whether or not the results should be histogrammed   *
*                                                                      *
*    Returned variables:                                               *
*       xinteg  :  value of integration                                *
*         xerr  :  integration error                                   *
*                                                                      *
*    This version is modified to work with photon processes.           *
*    At NLO one can have:                                              *
*                                                                      *
*    virt -> Born + virtual corrections + integrated QCD counterterms  *
*    real -> Real + subtraction terms                                  *
*                [+ QED photon-quark subtractions if frag=.true.]      *
*    frag -> Fragmentation contributions, incl. integrated QED dipoles *
*                                                                      *
*    tota -> virt + real [frag=.false.]                                *
*    tota -> virt + real + frag [frag=.true.]                          *
*                                                                      *
************************************************************************

      implicit none
      include 'gridinfo.f'
      include 'realwt.f'
      include 'scale.f'
      include 'facscale.f'
      include 'vegas_common.f'
      include 'PDFerrors.f'
      include 'frag.f'
      include 'reset.f'
      include 'masses.f'
      include 'process.f'
      include 'ipsgen.f'
      include 'part.f'
      include 'bypart.f'
      include 'nproc.f'
      integer myitmx,myncall,myinit,i,j,k,mynproc,myncall_save
      logical mybin,bin
      double precision sig,sd,chi,sigr,sdr,sigdk,sddk,chidk,
     & sigfrag,sdfrag,chifrag,sigWdk,sdWdk,chiWdk,
     & xreal,xreal2,xinteg,xerr,adjust,myscale,myfacscale,
     & mymb,sumsig,sumsigr,sumsigf,sumsd,sumsdr,sumsdf,
     & sigips(4),sdips(4),xcallwt
      character*4 mypart
      character*3 getstr,psgen
      common/mypart/mypart
      common/bin/bin
      common/xreal/xreal,xreal2
      double precision lowint,virtint,realint,fragint
      double precision region(2*mxdim)
      logical first,myreadin
      external lowint,virtint,realint,fragint
      data first/.true./
      save first,sigips,sdips

c--- Initialize all integration results to zero, so that the
c--- total of virt and real may be combined at the end for 'tota'
      sig=0d0
      sigr=0d0
      sigdk=0d0
      sigWdk=0d0
      sigfrag=0d0
      sd=0d0
      sdr=0d0
      sddk=0d0
      sdWdk=0d0
      sdfrag=0d0
      xreal=0d0
      xreal2=0d0
c--- integer controlling stages of Z+gamma+jet and Z+gamma+gamma processes
      ipsgen=1

      do j=-1,1
      do k=-1,1
        lord_bypart(j,k)=0d0
      enddo
      enddo
      if (PDFerrors) then
        do i=0,maxPDFsets
          PDFxsec(i)=0d0
        enddo
      endif

c--- Controls behaviour of gen_njets: need to reset phase-space
c--- boundaries when going from virt to real (using tota)
c--- need to reset scale also, for special scalestart values
      reset=.false.
      scalereset=.false.

c--- Put the vegasnr parameters in the common block
      itmx=myitmx
      ncall=myncall
      bin=mybin

c--- Store value of part in mypart, which will be retained;
c--- also store value of scale in myscale, which will be retained;
c--- part and scale can be changed to make sure that the tota option works.
      mypart=part
      myscale=scale
      myfacscale=facscale
      mynproc=nproc
      mymb=mb
      myncall_save=myncall

c--- special process: 5FNS + 4FNS: initialization
c---   for process 421 (426) we will actually run
c---   process 411 (416) [5FNS] and then add on the result of process 401 (406) [4FNS]
      if ((mynproc .eq. 421) .or. (mynproc .eq. 426)) then
        nproc=mynproc-10
      sumsig=0d0
      sumsigr=0d0
      sumsd=0d0
      sumsdr=0d0
      endif

c--- special handling of multiple PS generation for
c--- Z+gamma+jet and Z+gamma+gamma processes: we will loop
c--- over ipsgen=1,..,n where n=2 for Z+gamma+jet and n=4 for  Z+gamma+gamma
      if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     & .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     & .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     & .or.(doipsgen)) then
      sumsig=0d0
      sumsigr=0d0
      sumsigf=0d0
      sumsd=0d0
      sumsdr=0d0
      sumsdf=0d0
      endif

   77 continue
      if ((mynproc .eq. 421) .or. (mynproc .eq. 426)) then
        mb=mymb
      call chooser
        reset=.true.
        scalereset=.true.
c--- special write-out/read-in for 5FNS + 4FNS process
        if (first .eqv. .true.) then
          readin=.false.
          writeout=.true.
        if (nproc .ge. 411) then
            outgridfile='dvegas_5FNS_'//part//'.grid'
        else
            outgridfile='dvegas_4FNS_'//part//'.grid'
        endif
        else
          readin=.true.
          writeout=.false.
        if (nproc .ge. 411) then
            ingridfile='dvegas_5FNS_'//part//'.grid'
        else
            ingridfile='dvegas_4FNS_'//part//'.grid'
        endif
        endif
      endif

c--- special handling of multiple PS generation for
c--- Z+gamma+jet and Z+gamma+gamma processes
      if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     & .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     & .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     & .or.(doipsgen)) then
        reset=.true.
        scalereset=.true.
      psgen=getstr(ipsgen)
      write(6,*) '********* Phase space region ',ipsgen,' *********'
        if (first .eqv. .true.) then
          readin=.false.
          writeout=.true.
          outgridfile='dvegas_'//part//'_PS'//psgen(1:1)//'.grid'
        else
          readin=.true.
          writeout=.false.
          ingridfile='dvegas_'//part//'_PS'//psgen(1:1)//'.grid'
        endif
      endif

c--- Basic lowest-order integration
      if (part .eq. 'lord') then
!       call boundregion(ndim,region)
!       call vegasnr(region,ndim,lowint,myinit,myncall,myitmx,
!     .               nprn,sig,sd,chi)
       call vegas_Pomp(lowint,sig,0d0,0d0,ndim,myncall,myitmx,myinit)
      endif

c--- If we're doing the tota integration, then set up the grid info
      if ((mypart .eq. 'tota') .or. (mypart .eq. 'todk')) then
        if (first .and. (myinit .eq. 1)) then
c-- special input name for virtual grid
            ingridfile='dvegas_virt_'//ingridfile
            myreadin=readin
        else
          if (first .eqv. .true.) then
            readin=.false.
            writeout=.true.
            outgridfile='dvegas_virt.grid'
            if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     &       .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     &       .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     &       .or.(doipsgen)) then
              outgridfile='dvegas_virt_PS'//psgen(1:1)//'.grid'
          endif
          else
            readin=.true.
            writeout=.false.
            ingridfile='dvegas_virt.grid'
            if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     &       .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     &       .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     &       .or.(doipsgen)) then
              ingridfile='dvegas_virt_PS'//psgen(1:1)//'.grid'
          endif
          endif
        endif
      endif

c--- Virtual integration should have one extra dimension
c--- (added and then taken away)
      if (  (mypart .eq. 'virt') .or. (mypart .eq. 'tota')
     . .or. (mypart .eq. 'todk') )  then
        part='virt'
        reset=.true.
        scalereset=.true.
        ndim=ndim+1
!        call boundregion(ndim,region)
!        call vegasnr(region,ndim,virtint,myinit,myncall,myitmx,
!     .              nprn,sig,sd,chi)
       call vegas_Pomp(virtint,sig,0d0,0d0,ndim,myncall,myitmx,myinit)
        ndim=ndim-1
      endif

c--- If we're doing the tota integration, then set up the grid info
      if ((mypart .eq. 'tota') .or. (mypart .eq. 'todk')) then
        if (first .and. (myinit .eq. 1)) then
c-- special input name for real grid
          ingridfile(8:11)='real'
          readin=myreadin
        else
          if (first .eqv. .true.) then
            readin=.false.
            writeout=.true.
            outgridfile='dvegas_real.grid'
            if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     &       .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     &       .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     &       .or.(doipsgen)) then
              outgridfile='dvegas_real_PS'//psgen(1:1)//'.grid'
          endif
          else
            readin=.true.
            writeout=.false.
            ingridfile='dvegas_real.grid'
            if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     &       .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     &       .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     &       .or.(doipsgen)) then
              ingridfile='dvegas_real_PS'//psgen(1:1)//'.grid'
          endif
          endif
        endif
      endif

c--- Real integration should have three extra dimensions
c--- 'realwt' is a special option that in general should be false
c--- ('realwt' true samples the integral according to the
c---   unsubtracted real emission weight)
      if (mypart .eq. 'real') then
        part='real'
        scalereset=.true.
        if (realwt) then
          nprn=0
        endif
        xreal=0d0
        xreal2=0d0
        ndim=ndim+3
!        call boundregion(ndim,region)
!        call vegasnr(region,ndim,realint,myinit,myncall,myitmx,
!     .              nprn,sigr,sdr,chi)
        call vegas_Pomp(realint,sig,0d0,0d0,ndim,myncall,myitmx,myinit)
        ndim=ndim-3
        write(6,*)
        ncall=myncall
        if (realwt) then
          sigr=xreal
          sdr=dsqrt(abs((xreal2-xreal**2)/dfloat(ncall)))
          write(6,*) itmx,' iterations of ',ncall,' calls'
          write(6,*) 'Value of subtracted integral',sigr
          write(6,*) 'Error on subtracted integral',sdr
        endif
      endif
      if ((mypart .eq. 'tota') .or. (mypart .eq. 'todk')) then
        scale=myscale
        facscale=myfacscale
        part='real'
        reset=.true.
        if (realwt) then
          nprn=0
        endif
        xreal=0d0
        xreal2=0d0
        adjust=(dfloat(ndim+3))/(dfloat(ndim+1))
        ncall=int(dfloat(myncall)**adjust)/2
c--- cap on number of points, may be ndim-dependent, to ensure PS not too large
c        if (ndim .lt. 20) then
c        if (ncall .gt. myncall*20) ncall=myncall*20
c      else
        if (ncall .gt. myncall*10) ncall=myncall*10
c      endif
        write(6,*) 'Adjusting number of points for real to',ncall
        ndim=ndim+3
!        call boundregion(ndim,region)
!        call vegasnr(region,ndim,realint,myinit,ncall,myitmx,
!     .              nprn,sigr,sdr,chi)
        call vegas_Pomp(realint,sig,0d0,0d0,ndim,ncall,myitmx,myinit)
        ndim=ndim-3
        write(6,*)
        ncall=myncall

        if (realwt) then
          sigr=xreal
          sdr=dsqrt(abs((xreal2-xreal**2)/dfloat(ncall)))
          write(6,*) itmx,' iterations of ',ncall,' calls'
          write(6,*) 'Value of subtracted integral',sigr
          write(6,*) 'Error on subtracted integral',sdr
        endif
      endif

c--- If we're doing the todk integration, then set up the grid info
      if (mypart .eq. 'todk') then
        if (first .and. (myinit .eq. 1)) then
c-- special input name for real grid
          ingridfile(8:11)='redk'
          readin=myreadin
        else
          if (first .eqv. .true.) then
            readin=.false.
            writeout=.true.
            outgridfile='dvegas_redk.grid'
          else
            readin=.true.
            writeout=.false.
            ingridfile='dvegas_redk.grid'
          endif
        endif
      endif

      if (mypart .eq. 'todk')  then
        scale=myscale
        nproc=nproc+1
        call chooser
        part='real'
        reset=.true.
        if (realwt) then
          nprn=0
        endif
        xreal=0d0
        xreal2=0d0
        adjust=(dfloat(ndim+3))/(dfloat(ndim+1))
        ncall=int(dfloat(myncall)**adjust)/2
        write(6,*) 'Adjusting number of points for real to',ncall
        ndim=ndim+3
!        call boundregion(ndim,region)
!        call vegasnr(region,ndim,realint,myinit,ncall,myitmx,
!     .              nprn,sigdk,sddk,chidk)
        call vegas_Pomp(realint,sig,0d0,0d0,ndim,ncall,myitmx,myinit)
        ndim=ndim-3
        write(6,*)
        ncall=myncall
        nproc=nproc-1
        call chooser

        if (realwt) then
          sigdk=xreal
          sddk=dsqrt(abs((xreal2-xreal**2)/dfloat(ncall)))
          write(6,*) itmx,' iterations of ',ncall,' calls'
          write(6,*) 'Value of subtracted integral',sigdk
          write(6,*) 'Error on subtracted integral',sddk
        endif
      endif

c--- If we're doing the todk integration for ttbar production with
c--- a hadronic W decay, then set up the grid info
      if ((mypart .eq. 'todk') .and. (case .eq. 'tt_bbh')) then
        if (first .and. (myinit .eq. 1)) then
c-- special input name for real grid
          ingridfile(8:11)='rWdk'
          readin=myreadin
        else
          if (first .eqv. .true.) then
            readin=.false.
            writeout=.true.
            outgridfile='dvegas_rWdk.grid'
          else
            readin=.true.
            writeout=.false.
            ingridfile='dvegas_rWdk.grid'
          endif
        endif
      endif

      if ((mypart .eq. 'todk') .and. (case .eq. 'tt_bbh')) then
        scale=myscale
        nproc=nproc+2
        call chooser
        part='real'
        reset=.true.
        if (realwt) then
          nprn=0
        endif
        xreal=0d0
        xreal2=0d0
        adjust=(dfloat(ndim+3))/(dfloat(ndim+1))
        ncall=int(dfloat(myncall)**adjust)/2
        write(6,*) 'Adjusting number of points for real to',ncall
        ndim=ndim+3
!        call boundregion(ndim,region)
!        call vegasnr(region,ndim,realint,myinit,ncall,myitmx,
!     .              nprn,sigWdk,sdWdk,chiWdk)
      call vegas_Pomp(realint,sig,0d0,0d0,ndim,ncall,myitmx,myinit)
        ndim=ndim-3
        write(6,*)
        ncall=myncall
        nproc=nproc-2
        call chooser

        if (realwt) then
          sigWdk=xreal
          sdWdk=dsqrt(abs((xreal2-xreal**2)/dfloat(ncall)))
          write(6,*) itmx,' iterations of ',ncall,' calls'
          write(6,*) 'Value of subtracted integral',sigdk
          write(6,*) 'Error on subtracted integral',sddk
        endif
      endif

c--- Fragmentation contribution: only if frag is set to .true.
c--- If we're doing the tota integration and , then set up the grid info
      if ((mypart .eq. 'tota') .and. (frag)) then
        if (first .and. (myinit .eq. 1)) then
c-- special input name for frag grid
          ingridfile(8:11)='frag'
          readin=myreadin
        else
          if (first .eqv. .true.) then
            readin=.false.
            writeout=.true.
            outgridfile='dvegas_frag.grid'
            if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     &       .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     &       .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     &       .or.(doipsgen)) then
              outgridfile='dvegas_frag_PS'//psgen(1:1)//'.grid'
          endif
          else
            readin=.true.
            writeout=.false.
            ingridfile='dvegas_frag.grid'
            if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     &       .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     &       .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     &       .or.(doipsgen)) then
              ingridfile='dvegas_frag_PS'//psgen(1:1)//'.grid'
            endif
          endif
        endif
      endif

c--- special handling of multiple PS generation for
c--- Z+gamma+jet and Z+gamma+gamma processes:
c---  fragmentation pieces only contribute for
c---   ipsgen=1 (Z+gamma+jet)
c---   ipsgen=1,2 (Z+gamma+gamma)
c---   ipsgen=1,3 (W+gamma+gamma)
      if (((mynproc .eq. 301) .and. (ipsgen .gt. 2)) .or.
     &    ((mynproc .eq. 302) .and. (ipsgen .gt. 1)) .or.
     &    ((mynproc .eq. 370) .and. ((ipsgen .eq. 2).or.(ipsgen.eq.4)))
     & .or.((mynproc .eq. 371) .and. ((ipsgen .eq. 2).or.(ipsgen.eq.4)))
     &     )then
        sigfrag=0d0
        sdfrag=0d0
        goto 33
      endif

      if ( ((mypart .eq. 'tota') .and. (frag))
     & .or. (mypart .eq. 'frag') ) then
         part='frag'
         scale=myscale
         facscale=myfacscale
         if (mypart .eq. 'frag') then
         scalereset=.true.
         else
         reset=.true.
         endif
         ncall=myncall
c         write(6,*) 'Adjusting number of points for frag to',ncall
         ndim=ndim+1
!         call boundregion(ndim,region)
         fragint_mode=.true.            ! for isolation
!         call vegasnr(region,ndim,fragint,myinit,myncall,myitmx,
!     &                 nprn,sigfrag,sdfrag,chifrag)
         call vegas_Pomp(fragint,sig,0d0,0d0,ndim,myncall,myitmx,myinit)
         fragint_mode=.false.            ! for isolation
         ndim=ndim-1
       rescale=.false.       ! turn rescaling off again
      endif

   33 continue

c--- special process: 5FNS + 4FNS: initialization
c---   for process 421 (426) we will actually run
c---   process 411 (416) [5FNS] and then add on the result of process 401 (406) [4FNS]
      if ((mynproc .eq. 421) .or. (mynproc .eq. 426)) then
        sumsig=sumsig+sig
        sumsigr=sumsigr+sigr
        sumsd=sumsd+sd**2
        sumsdr=sumsdr+sdr**2
        if (nproc .ge. 411) then
          nproc=nproc-10
        goto 77
      endif
c--- return nproc to the value from the input file
        nproc=mynproc
      sig=sumsig
      sigr=sumsigr
      sd=dsqrt(sumsd)
      sdr=dsqrt(sumsdr)
      endif

c--- special handling of multiple PS generation for
c--- Z+gamma+jet and Z+gamma+gamma processes: we will loop
c--- over ipsgen=1,..,n where n=2 for Z+gamma+jet and n=4 for  Z+gamma+gamma
      if ( (mynproc .eq. 301) .or. (mynproc .eq. 302)
     & .or.(mynproc .eq. 303) .or. (mynproc .eq. 304)
     & .or.(mynproc .eq. 370) .or. (mynproc .eq. 371)
     & .or.(doipsgen)) then
c--- store cross section and standard deviation info for this region on first run
        if (myinit .eq. 0) then
          sigips(ipsgen)=sig+sigr+sigfrag
          sdips(ipsgen)=sqrt(sd**2+sdr**2+sdfrag**2)
        endif
        sumsig=sumsig+sig
        sumsigr=sumsigr+sigr
        sumsigf=sumsigf+sigfrag
        sumsd=sumsd+sd**2
        sumsdr=sumsdr+sdr**2
        sumsdf=sumsdf+sdfrag**2
        ipsgen=ipsgen+1
        if ((((nproc .eq. 302).or.(nproc .eq. 304)).and.(ipsgen .le. 2))
     &  .or.(((nproc .eq. 301).or.(nproc .eq. 303)).and.(ipsgen .le. 4))
     &  .or.(((nproc .eq. 370).or.(nproc .eq. 371)).and.(ipsgen .le. 4))
     &  .or.((doipsgen).and.(ipsgen .le. maxipsgen))
     &     ) then
c--- W+2 photons case
          if ((nproc .eq. 370).or.(nproc .eq. 371)) then
            if ((myinit .eq. 1) .and. (ipsgen .gt. 1)) then
c--- dynamic scaling of points on second run according to uncertainties found in first
              xcallwt=(sdips(ipsgen)/sdips(1))
              if (xcallwt .lt. 0.2d0) xcallwt=0.2d0
              if (xcallwt .gt. 5d0) xcallwt=5d0
              myncall=int(float(myncall_save)*xcallwt)
c              write(6,*) '>>>>>> Dynamic scaling factor = ',
c     &                    xcallwt,' for ipsgen=',ipsgen
            endif
            goto 77
          endif
c--- change number of PS points in different regions
          if ((nproc.eq.301).or.(nproc.eq.303)
     &    .or.(nproc.eq.370).or.(nproc.eq.371)) then
             if (ipsgen.eq.2) then
                myncall=10*myncall
             elseif (ipsgen.eq.3) then
                myncall=myncall/10
                myncall=5*myncall
             elseif (ipsgen.eq.4) then
                myncall=myncall
             endif
          endif
          myncall=myncall
          goto 77
      endif
      myncall=myncall
      sig=sumsig
      sigr=sumsigr
      sigfrag=sumsigf
      sd=dsqrt(sumsd)
      sdr=dsqrt(sumsdr)
      sdfrag=dsqrt(sumsdf)
      endif

c--- calculate integration variables to be returned
      xinteg=sig+sigr+sigdk+sigWdk+sigfrag
      xerr=dsqrt(sd**2+sdr**2+sddk**2+sdWdk**2+sdfrag**2)

c--- return part, scale and myncall to their real values
      part=mypart
      scale=myscale
      myncall=myncall_save
      first=.false.

      return
      end

      subroutine boundregion(idim,region)
c--- Initializes integration region [0,1] for each variable
c--- in the idim-dimensional integration range
      implicit none
      include 'mxdim.f'
      integer i,idim
      double precision region(2*mxdim)

      do i=1,idim
      region(i)=0d0
      region(i+idim)=1d0
      enddo

      return
      end


      SUBROUTINE DEREQT(DEP)
C
      IMPLICIT REAL*8(A-H,O-Z)
C
      COMMON/ADDMOM/ HDUMMY(9),HTIP(3)
C
      COMMON/DEBUG2/ IOUT,JOUT,KLUGE
C
      COMMON/INEWR /NKT(10),ICP,ICPS
C
      COMMON/INTTRP/ITPROT,NUMTIP(10)
C
      COMMON/IPOOL1/IGRAV,IDAMP,IK,K1,ITIM,IAB,IAPS,IBB,IBPS,NK(10)
     1             ,LK(10),LLK(10)
C
      COMMON/RNEWC / ZGJ(10),ZEDQ(10),ZO(10),ZED2(10),ZED3(10)
C
      COMMON/RNEWR / ZA(10),CI3(10),C2OV3(10)
C
      COMMON/RPOOL1/RHOK(10),TIME,SA(3,3),FM1(3,3),ZLK(10),OMEG(3)
     1             ,ZLKP(10),ZLKPP(10),CMAT(3,3),GBAR(3,3),YBCM(3)
     2             ,ZBZK(3,10),FCM(3,3),DTO,PHID,PHI
C
      COMMON/RPOOL5/CKMAT(3,3,10),FM2(3,3)
C
      COMMON/RPOOL9/RT1(7),RT2(10,9),ALP(7,7),GAM(10,9,7),DEL(10,9,9)
C
      COMMON/ITWWRK/NKB,NTW,NTT,ILK,ILLK
C
      COMMON/TWWORK/FM(3,3),A(3),AD(3),B(3),BD(3),C(3),CD(3),ZL,RO
     1             ,RSQT(3),W2,W3,EIM,ED2,ED3,EDP,GJ,HKT(3)
C
      COMMON/TWWRK1/WV(228)
C
      COMMON/TMSINR/ TIPINR(3,10),RSQ(3,10),XIPL(6),BETL(6)
C
      COMMON/TPWORK/ XIPK(3),BETK(3)
C
      COMMON/TWIDMP/ CDTW(3,10)
C
      COMMON/WRKTDP/ CDMP(3)
C
C
      DIMENSION DEP(150),YY(3,3),YYD(3,3),ZZ(3,3),ZZD(3,3),YYDD(3)
C
      DIMENSION ZZDD(3)
C
      DIMENSION DUM1(3,3),DUM2(3,3),DUM3(3,3)
C
      DIMENSION GBY(3,3),GBK(3,3),OMK(3),VW1(3),VW2(3)
C
      DIMENSION YKYDD(3),YKYD(3,3),YKY(3,3)
C
      DIMENSION CON2(3),CON3(3),GGM(3),II(3),JJ(3)
C
      DIMENSION OMZ(3),GBZ(3,3),ZKZ(3,3),ZKZD(3,3),ZKZDD(3)
C
      DIMENSION     XX(3,3),XXD(3,3),XXDD(3),XXA(3,3,3),XXB(3,3,3)
     1             ,XXC(3,3,3),XDXA(3,3),XDXB(3,3),XDXC(3,3),XDDXA(3)
     2             ,XDDXB(3),XDDXC(3),XAX(3,3),XBX(3,3),XCX(3,3)
     3             ,DLAA(3,3),DLAB(3,3),DLAC(3,3),DLBB(3,3),DLBC(3,3)
     4             ,DLCC(3,3),VIFA(3),VIFB(3),VIFC(3)
C
      EQUIVALENCE (WV(1),XX(1,1)),(WV(10),XXD(1,1)),(WV(19),XXDD(1))
     1           ,(WV(22),XXA(1,1,1)),(WV(44),XXB(1,1,1))
     2           ,(WV(76),XXC(1,1,1)),(WV(103),XDXA(1,1))
     3           ,(WV(103),XDXA(1,1)),(WV(112),XDXB(1,1))
     4           ,(WV(121),XDXC(1,1)),(WV(130),XDDXA(1))
     5           ,(WV(133),XDDXB(1)),(WV(136),XDDXC(1))
     6           ,(WV(139),XAX(1,1)),(WV(148),XBX(1,1))
     7           ,(WV(157),XCX(1,1)),(WV(166),DLAA(1,1))
     8           ,(WV(175),DLAB(1,1)),(WV(184),DLAC(1,1))
     9           ,(WV(193),DLBB(1,1)),(WV(202),DLBC(1,1))
     A           ,(WV(211),DLCC(1,1)),(WV(220),VIFA(1))
     B           ,(WV(223),VIFB(1)),(WV(226),VIFC(1))
C
      DATA II/2,3,1/,JJ/3,1,2/
C
      DATA DZERO/0.0D0/
C
C     EXTRACT INTEGER DATA
      IF(IOUT.NE.1) WRITE(6,6004) RT1
C
      IA=IAB-1
      IB=IBB-1
      IC=ICP-1
C
C     ZERO OUT SYSTEM ARRAYS
C
      DO 2 I=1,3
      DO 1 J=1,3
      YY(I,J)=DZERO
      YYD(I,J)=DZERO
      ZZ(I,J)=DZERO
      ZZD(I,J)=DZERO
    1 CONTINUE
      YYDD(I)=DZERO
      ZZDD(I)=DZERO
      HTIP(I)=DZERO
    2 CONTINUE
C
      CALL MPYMAT(SA,GBAR,SA,2,2,DUM1,GBY)
C
      IF(IOUT.NE.1) WRITE(6,6001) DEP
C
C     CONSTRUCT K - LOOP FOR ELEMENTS
C
      DO 500 K=1,IK
C
C     EXTRACT INTEGER CONTROL VARIABLES
C
      NKB=NK(K)
      NTW=NKT(K)
      NTT=NUMTIP(K)
      ILK=LK(K)
      ILLK=LLK(K)
C
      ITEST=NTW+NTT
      IF(ITEST.EQ.0) GO TO 500
C
C     EXTRACT TRANSFORMATION MATRICES
C
      DO 5 I=1,3
      DO 4 J=1,3
      CMAT(I,J)=CKMAT(I,J,K)
      IF(K.GT.K1) GO TO 3
      FM(I,J)=FM1(I,J)
      GO TO 4
    3 CONTINUE
      FM(I,J)=FM2(I,J)
    4 CONTINUE
      HKT(I)=DZERO
    5 CONTINUE
C
      CALL MPYMAT(FM,CMAT,DUM1,1,1,FCM,DUM1)
C
C     EXTRACT ELEMENT DEPENDENT VARIABLES FROM DEP VECTOR
C
      DO 6 I=1,3
      A(I)=DZERO
      B(I)=DZERO
      C(I)=DZERO
      AD(I)=DZERO
      BD(I)=DZERO
      CD(I)=DZERO
    6 CONTINUE
C
      IF(NKB.EQ.0) GO TO 15
C
      DO 12 I=1,NKB
      I1=IA+I
      I2=I1+NKB
      I3=IB+I
      I4=I3+NKB
      A(I)=DEP(I1)
      AD(I)=DEP(I2)
      B(I)=DEP(I3)
      BD(I)=DEP(I4)
   12 CONTINUE
C
   15 CONTINUE
C
      IF(NTW.EQ.0) GO TO 20
C
      DO 17 I=1,NTW
      I1=IC+I
      I2=I1+NTW
      C(I)=DEP(I1)
      CD(I)=DEP(I2)
   17 CONTINUE
C
   20 CONTINUE
C
C     EXTRACT ELEMENT DATA
C
      ZL=ZLK(K)
      RO=RHOK(K)
C
C     FILL IN FOR RSQT,W2,W3,EIM,ED2,ED3,EDP,GJ
C
      EIM=ZO(K)
      ED2=ZED2(K)
      ED3=ZED3(K)
      EDP=ZEDQ(K)
      GJ=ZGJ(K)
      I11=0
      IF(ILK.EQ.2) I11=3
      WS1=ZL*RO
      DO 21 I=1,3
      IND=I11+I
      RSQT(I)=RSQ(I,K)/WS1
      CDMP(I)=CDTW(I,K)
      XIPK(I)=XIPL(IND)
      BETK(I)=BETL(IND)
   21 CONTINUE
      W3=CI3(K)/ZA(K)/144.0D0
      W2=W3*C2OV3(K)
C
C
C     ZERO OUT WORK COMMON
C
      DO 50 I=1,228
      WV(I)=DZERO
   50 CONTINUE
C
      IF(IOUT.NE.1) WRITE(6,6001) W2,W3,ZL,RO,EIM,ED2,ED3,EDP,GJ
      IF(IOUT.NE.1) WRITE(6,6001) A,B,C
      IF(IOUT.NE.1) WRITE(6,6001) XIPK,BETK,RSQT
C
C     CONSTRUCT BASIC ARRAYS FOR TIP MASS
C
      IF(NTT.EQ.0) GO TO 55
C
      CALL FNDTIP
C
      IF(IOUT.EQ.1) GO TO 55
      WRITE(6,6000)
      WRITE(6,6001) WV
   55 CONTINUE
C
C
C     ADD TWIST EQUATIONS IF TWIST IS PRESENT
C
      IF(NTW.EQ.0) GO TO 60
C
      CALL FNDINT
C
      CALL FINDTW
C
   60 CONTINUE
C
      IF(IOUT.EQ.1) GO TO 61
      WRITE(6,6000)
      WRITE(6,6001)  WV
 6000 FORMAT('0',10X,'WORK VECTOR FROM DEREQT'/)
 6001 FORMAT(' ',1P9E14.6)
   61 CONTINUE
C
      ITEST1=NKB+NTW
C
      IF(ITEST1.EQ.0) GO TO 400
C
C
C     ADD TIP MASS AND TWIST EFFECTS FOR THIS ELEMENT
C
      DO 62 I=1,3
      OMK(I)=FCM(1,I)*OMEG(1)+FCM(2,I)*OMEG(2)+FCM(3,I)*OMEG(3)
      HTIP(I)=HTIP(I)+FCM(1,I)*HKT(1)+FCM(2,I)*HKT(2)+FCM(3,I)*HKT(3)
   62 CONTINUE
C
      IF(IDAMP.EQ.0.OR.K.GT.K1) GO TO 70
      DO 65 I=1,3
      OMK(I)=OMK(I)+CMAT(I,2)*PHID
   65 CONTINUE
C
   70 CONTINUE
C
      O11=OMK(1)*OMK(1)
      O12=OMK(1)*OMK(2)
      O13=OMK(1)*OMK(3)
      O22=OMK(2)*OMK(2)
      O23=OMK(2)*OMK(3)
      O33=OMK(3)*OMK(3)
C
C     TRANSFORM GBY TO ELEMENT FRAME
C
      CALL MPYMAT(FCM,GBY,FCM,2,2,DUM1,GBK)
C
      NKB2=2*NKB
C
      IF(NKB.EQ.0) GO TO 200
C
      DO 100 I=1,NKB
      I1=NKB+I
C
C     AUGMENT DELTA MATRIX
C
      DO 72 J=1,NKB
      J1=NKB+J
      DEL(K,I,J)=DEL(K,I,J)+DLAA(I,J)
      DEL(K,I,J1)=DEL(K,I,J1)+DLAB(I,J)
      DEL(K,I1,J1)=DEL(K,I1,J1)+DLBB(I,J)
      DEL(K,J1,I)=DEL(K,I,J1)
   72 CONTINUE
C
      IF(NTW.EQ.0) GO TO 75
C
      DO 74 J=1,NTW
      J1=NKB2+J
      DEL(K,I,J1)=DEL(K,I,J1)+DLAC(I,J)
      DEL(K,I1,J1)=DEL(K,I1,J1)+DLBC(I,J)
      DEL(K,J1,I)=DEL(K,I,J1)
      DEL(K,J1,I1)=DEL(K,I1,J1)
   74 CONTINUE
C
   75 CONTINUE
C
C     AUGMENT GAMMA SYSTEM COUPLING MATRIX
C
      DO 76 J=1,3
      VW1(J)=FCM(J,1)*XAX(I,1)+FCM(J,2)*XAX(I,2)+FCM(J,3)*XAX(I,3)
      VW2(J)=FCM(J,1)*XBX(I,1)+FCM(J,2)*XBX(I,2)+FCM(J,3)*XBX(I,3)
   76 CONTINUE
C
      DO 78 J=1,3
      J1=J+3
      GAM(K,I,J1)=GAM(K,I,J1)+VW1(J)
      GAM(K,I1,J1)=GAM(K,I1,J1)+VW2(J)
   78 CONTINUE
C
      IF(IDAMP.EQ.0.OR.K.GT.K1) GO TO 80
C
      WS1=CMAT(2,1)*XAX(I,1)+CMAT(2,2)*XAX(I,2)+CMAT(2,3)*XAX(I,3)
      WS2=CMAT(2,1)*XBX(I,1)+CMAT(2,2)*XBX(I,2)+CMAT(2,3)*XBX(I,3)
C
      GAM(K,I,7)=GAM(K,I,7)+WS1
      GAM(K,I1,7)=GAM(K,I1,7)+WS2
C
   80 CONTINUE
C
C     FIND GRAVITY GRADIENT FORCES FOR AN AND BN EQUATIONS
C
      SUMA=DZERO
      SUMB=DZERO
      DO 85 J=1,3
      DO 85 L=1,3
      SUMA=SUMA+GBK(J,L)*XXA(I,J,L)
      SUMB=SUMB+GBK(J,L)*XXB(I,J,L)
   85 CONTINUE
C
C     FIND INERTIAL TERMS FOR AN AND BN EQUATIONS
C
      CONA2=OMK(1)*XDXA(I,1)+OMK(2)*XDXA(I,2)+OMK(3)*XDXA(I,3)
      CONB2=OMK(1)*XDXB(I,1)+OMK(2)*XDXB(I,2)+OMK(3)*XDXB(I,3)
      CONA2=2.0D0*CONA2
      CONB2=2.0D0*CONB2
C
      CONA3=-(O22+O33)*XXA(I,1,1)-(O33+O11)*XXA(I,2,2)
     1      -(O11+O22)*XXA(I,3,3)+O12*(XXA(I,1,2)+XXA(I,2,1))
     2      +O13*(XXA(I,1,3)+XXA(I,3,1))+O23*(XXA(I,2,3)+XXA(I,3,2))
      CONB3=-(O22+O33)*XXB(I,1,1)-(O33+O11)*XXB(I,2,2)
     1      -(O11+O22)*XXB(I,3,3)+O12*(XXB(I,1,2)+XXB(I,2,1))
     2      +O13*(XXB(I,1,3)+XXB(I,3,1))+O23*(XXB(I,2,3)+XXB(I,3,2))
C
      RT2(K,I)=RT2(K,I)+SUMA-XDDXA(I)-CONA2-CONA3-VIFA(I)
      RT2(K,I1)=RT2(K,I1)+SUMB-XDDXB(I)-CONB2-CONB3-VIFB(I)
C
C
      IF(IOUT.EQ.1) GO TO 100
      WRITE(6,6005) I
 6005 FORMAT('0 OUTPUT FROM BENDING LOOP FOR MODE',I2/)
      WRITE(6,6006) SUMA,XDDXA(I),CONA2,CONA3,VIFA(I)
      WRITE(6,6006) SUMB,XDDXB(I),CONB2,CONB3,VIFB(I)
 6006 FORMAT(' ',5X,1P5E14.6)
C
  100 CONTINUE
C
C
C
  200 CONTINUE
C
C     ADD TWIST EQUATION
C
      IF(NTW.EQ.0) GO TO 400
C
      DO 300 I=1,NTW
      I1=NKB2+I
C
C     AUGMENT DELTA MATRIX
C
      DO 210 J=1,NTW
      J1=NKB2+J
      DEL(K,I1,J1)=DLCC(I,J)
  210 CONTINUE
C
C
C
      DO 212 J=1,3
      VW1(J)=FCM(J,1)*XCX(I,1)+FCM(J,2)*XCX(I,2)+FCM(J,3)*XCX(I,3)
  212 CONTINUE
C
      DO 214 J=1,3
      J1=J+3
      GAM(K,I1,J1)=GAM(K,I1,J1)+VW1(J)
  214 CONTINUE
C
      IF(IDAMP.EQ.0.OR.K.GT.K1) GO TO 220
C
      WS1=CMAT(2,1)*XCX(I,1)+CMAT(2,2)*XCX(I,2)+CMAT(2,3)*XCX(I,3)
C
      GAM(K,I1,7)=GAM(K,I1,7)+WS1
C
  220 CONTINUE
C
C     GRAVITY GRADIENT FOR TWIST EQUATION
C
      SUMC=DZERO
      DO 230 J=1,3
      DO 230 L=1,3
      SUMC=SUMC+GBK(J,L)*XXC(I,J,L)
  230 CONTINUE
C
C     INERTIAL TERMS FOR TWIST EQUATION
C
      CONC2=OMK(1)*XDXC(I,1)+OMK(2)*XDXC(I,2)+OMK(3)*XDXC(I,3)
      CONC2=2.0D0*CONC2
C
      CONC3=-(O22+O33)*XXC(I,1,1)-(O33+O11)*XXC(I,2,2)
     1      -(O11+O22)*XXC(I,3,3)+O12*(XXC(I,1,2)+XXC(I,2,1))
     2      +O13*(XXC(I,1,3)+XXC(I,3,1))+O23*(XXC(I,2,3)+XXC(I,3,2))
C
      RT2(K,I1)=RT2(K,I1)+SUMC-XDDXC(I)-CONC2-CONC3-VIFC(I)
C
C
      IF(IOUT.EQ.1) GO TO 300
      WRITE(6,6007) I
 6007 FORMAT('0 OUTPUT FROM TWIST LOOP FOR MODE',I2/)
      WRITE(6,6006) SUMC,XDDXC(I),CONC2,CONC3,VIFC(I)
C
  300 CONTINUE
C
C
C
  400 CONTINUE
C
C     TRANSFORM SYSTEM TERMS TO MAIN BODY FRAME
C
      DO 410 J=1,3
      YKYDD(J)=FCM(J,1)*XXDD(1)+FCM(J,2)*XXDD(2)+FCM(J,3)*XXDD(3)
  410 CONTINUE
C
      CALL MPYMAT(FCM,XXD,FCM,2,2,DUM1,YKYD)
      CALL MPYMAT(FCM,XX,FCM,2,2,DUM1,YKY)
C
C     SUM CONTRIBUTION TO SYSTEM EQUATIONS
C
      CON=RO*ZL
C
      DO 420 I=1,3
      DO 419 J=1,3
      YY(I,J)=YY(I,J)+YKY(I,J)*CON
      YYD(I,J)=YYD(I,J)+YKYD(I,J)*CON
  419 CONTINUE
      YYDD(I)=YYDD(I)+YKYDD(I)*CON
  420 CONTINUE
C
C     INCREMENT COUNTERS
C
      IA=IA+NKB2
      IB=IB+NKB2
      IC=IC+2*NTW
C
C     ADD IF DAMPER ELEMENT
C
      IF(IDAMP.EQ.0.OR.K.GT.K1) GO TO 500
C
      DO 430 J=1,3
      ZKZDD(J)=CMAT(J,1)*XXDD(1)+CMAT(J,2)*XXDD(2)+CMAT(J,3)*XXDD(3)
  430 CONTINUE
C
      CALL MPYMAT(CMAT,XXD,CMAT,2,2,DUM1,ZKZD)
      CALL MPYMAT(CMAT,XX,CMAT,2,2,DUM1,ZKZ)
C
      DO 440 I=1,3
      DO 439 J=1,3
      ZZ(I,J)=ZZ(I,J)+ZKZ(I,J)*CON
      ZZD(I,J)=ZZD(I,J)+ZKZD(I,J)*CON
  439 CONTINUE
      ZZDD(I)=ZZDD(I)+ZKZDD(I)*CON
  440 CONTINUE
C
C
C
  500 CONTINUE
C
C
C     AUGMENT SYSTEM EQUATIONS
C
C     GRAVITY GRADIENT MOMENTS
      DO 540 I=1,3
      I1=II(I)
      J1=JJ(I)
      GGM(I)=DZERO
      DO 535 J=1,3
      GGM(I)=GGM(I)+YY(I1,J)*GBY(J1,J)-YY(J1,J)*GBY(I1,J)
  535 CONTINUE
  540 CONTINUE
C
C     CONSTRUCT INERTIAL TERMS
C
      WS1=YYD(1,1)+YYD(2,2)+YYD(3,3)
      DO 560 I=1,3
      CON2(I)=-YYD(1,I)*OMEG(1)-YYD(2,I)*OMEG(2)-YYD(3,I)*OMEG(3)
      CON2(I)=CON2(I)+OMEG(I)*WS1
      CON2(I)=2.0D0*CON2(I)
  560 CONTINUE
C
      WS1=OMEG(1)*OMEG(1)+OMEG(2)*OMEG(2)+OMEG(3)*OMEG(3)
C
      DO 580 I=1,3
      I1=II(I)
      J1=JJ(I)
      CON3(I)=DZERO
      DO 570 J=1,3
      CON3(I)=CON3(I)+OMEG(I)*OMEG(J)*(YY(I1,J)-YY(J1,J))
  570 CONTINUE
      CON3(I)=CON3(I)-WS1*(YY(I1,I)-YY(J1,I))
  580 CONTINUE
C
C     INCREMENT ALP MATRIX AND RT1
C
      WS1=YY(1,1)+YY(2,2)+YY(3,3)
      DO 600 I=1,3
      I1=I+3
      DO 595 J=1,3
      J1=J+3
      ALP(I1,J1)=ALP(I1,J1)-YY(I,J)
  595 CONTINUE
      ALP(I1,I1)=ALP(I1,I1)+WS1
      RT1(I1)=RT1(I1)+GGM(I)-YYDD(I)-CON2(I)-CON3(I)
  600 CONTINUE
C
C     IF DAMPER CASE AUGMENT DAMPER EQUATION
C
      IF(IDAMP.EQ.0) GO TO 800
C
C     GRAVITY GRADIENT MOMENT
C
      CALL MPYMAT(FM1,GBY,FM1,2,2,DUM1,GBZ)
C
      I1=3
      J1=1
      SUMD=DZERO
      DO 720 I=1,3
      SUMD=SUMD+GBZ(J1,I)*ZZ(I1,I)-GBZ(I1,I)*ZZ(J1,I)
  720 CONTINUE
C
C     INERTIA TERMS FOR DAMPER EQUATION
C
      DO 730 I=1,3
      OMZ(I)=FM1(1,I)*OMEG(1)+FM1(2,I)*OMEG(2)+FM1(3,I)*OMEG(3)
  730 CONTINUE
C
      COND2=-ZZD(1,2)*OMZ(1)+(ZZD(3,3)+ZZD(1,1))*(OMZ(2)+PHID)
     1      -ZZD(3,2)*OMZ(3)
      COND2=2.0D0*COND2
C
      COND3=(OMZ(1)*OMZ(1)-OMZ(3)*OMZ(3))*ZZ(1,3)
     1      +OMZ(1)*OMZ(3)*(ZZ(3,3)-ZZ(1,1))
     2      +OMZ(2)*(OMZ(1)*ZZ(2,3)-OMZ(3)*ZZ(1,2))
C
C     SYSTEM INERTIA TERMS DUE TO DAMPER MOTION
C
      WS1=2.0D0*PHID
      WS2=PHID*PHID
C
      VW1(1)=-WS1*ZZD(2,1)
      VW1(2)=WS1*(ZZD(3,3)+ZZD(1,1))
      VW1(3)=-WS1*ZZD(2,3)
C
      VW2(1)=-WS1*(OMZ(3)*ZZ(3,3)-OMZ(1)*ZZ(1,3)+OMZ(2)*ZZ(2,3))
     1       -WS2*ZZ(2,3)
      VW2(2)=DZERO
      VW2(3)=WS1*(OMZ(3)*ZZ(1,3)-OMZ(1)*ZZ(1,1)+OMZ(2)*ZZ(1,2))
     1       +WS2*ZZ(1,3)
C
      DO 735 I=1,3
      CON2(I)=FM1(I,1)*VW1(1)+FM1(I,2)*VW1(2)+FM1(I,3)*VW1(3)
      CON3(I)=FM1(I,1)*VW2(1)+FM1(I,2)*VW2(2)+FM1(I,3)*VW2(3)
      I3=I+3
      RT1(I3)=RT1(I3)-CON2(I)-CON3(I)
  735 CONTINUE
C
C     AUGMENT ALP MATRIX AND RT1
C
      WS1=ZZ(3,3)+ZZ(1,1)
C
      ALP(7,4)=ALP(7,4)-ZZ(1,2)*FM1(1,1)+WS1*FM1(1,2)-ZZ(2,3)*FM1(1,3)
      ALP(7,5)=ALP(7,5)-ZZ(1,2)*FM1(2,1)+WS1*FM1(2,2)-ZZ(2,3)*FM1(2,3)
      ALP(7,6)=ALP(7,6)-ZZ(1,2)*FM1(3,1)+WS1*FM1(3,2)-ZZ(2,3)*FM1(3,3)
      ALP(7,7)=ALP(7,7)+WS1
      ALP(4,7)=ALP(7,4)
      ALP(5,7)=ALP(7,5)
      ALP(6,7)=ALP(7,6)
C
      RT1(7)=RT1(7)+SUMD-ZZDD(2)-COND2-COND3
C
C
  800 CONTINUE
C
C
      IF(IOUT.EQ.1) GO TO 900
      WRITE(6,6002)
 6002 FORMAT('0',5X,'ALP FROM DEREQT'/)
      WRITE(6,6003) ALP
 6003 FORMAT(' ',1P7E14.6)
      WRITE(6,6001) GBY,YY,YYD,YYDD,GGM,CON2,CON3,OMEG
      WRITE(6,6004) RT1
 6004 FORMAT('0RT1  ',1P7E14.6)
  900 CONTINUE
C
C
      RETURN
C
      END


      SUBROUTINE PCOORD (PEN)
C
C     PLOTS A COORDINATE TRIAD AT THE LOWER RIGHT CORNER OF A STRUCTURAL
C     PLOT. THIS ROUTINE IS CALLED ONLY BY DRAW
C
C     WRITTEN BY G.CHAN/UNISYS      10/1990
C
      INTEGER         PEN,FPLTIT,SYM(2)
      COMMON /XXPARM/ IDUMM(215),FPLTIT
      COMMON /PLTDAT/ IDUM20(20),SIZE,IDUM2(2),CNTCHR(2)
      COMMON /DRWAXS/ G(3,4)
C
C
C     COMPUTE THE ORIGIN, WHICH IS A FUNCTION OF FRAME SIZE, CHARACTER
C     VERTICAL AND HORIZONTAL SCALES, PRESENCE OF PTITLE LINE, AND THE
C     OVERALL SIZE OF THE TRIAD
C
C     ALL THE NUMERIC MULTIPLIERS USED BELOW WERE WORKED OUT WITH FRAME
C     SIZE OF 1023.0. THEY SHOULD BE APPLICABLE TO FRAME SIZE OF 3000.
C
      X2 = 0.0
      Y2 = 0.0
      Y1 = 0.0
      DO 10 I = 1,3
      IF (G(2,I) .GT. X2) X2 = G(2,I)
      IF (G(3,I) .LT. Y2) Y2 = G(3,I)
      IF (G(3,I) .GT. Y1) Y1 = G(3,I)
   10 CONTINUE
      DE = 1.8*CNTCHR(1)
      SF = 2.7*CNTCHR(2)
      IF (FPLTIT .EQ. 0) SF = 1.3*SF
      SF = SF/(Y1-Y2)
      X1 = SIZE - X2*SF - DE
      Y1 = -Y2*SF
      IF (FPLTIT .NE. 0) Y1 = Y1 + 0.8*CNTCHR(2)
      EP = 0.0001
      OF = -1.
      IF (G(2,1).LE.EP .AND. G(2,2).LE.EP .AND. G(2,3).LE.EP) OF = +1.
      IF (OF .EQ. +1.) X1 = X1 - DE
C
C     DRAW THE X-Y-Z COORDINATE TRIAD
C     DRAW A CIRCLE AT THE ORIGIN IF ANY AXIS IS IN LINE WITH VIEWER
C
      SYM(1) = 6
      SYM(2) = 0
      DE = 0.8*CNTCHR(1)
      OF = 1.3*OF*CNTCHR(1)
      DO 30 I = 1,3
      X2 = G(2,I)*SF + X1
      Y2 = G(3,I)*SF + Y1
      CALL LINE (X1,Y1,X2,Y2,PEN,0)
      IF (ABS(G(2,I))+ABS(G(3,I)) .GE. EP) GO TO 20
      CALL SYMBOL (X1,Y1,SYM,0)
      CALL TIPE (X2+OF,Y2,1,G(I,4),1,0)
      GO TO 30
   20 IF (G(2,I) .GT. 0.0) CALL TIPE (X2+DE,Y2,1,G(I,4),1,0)
      IF (G(2,I) .LE. 0.0) CALL TIPE (X2-DE,Y2,1,G(I,4),1,0)
   30 CONTINUE
C
      RETURN
      END


!/ ------------------------------------------------------------------- /
      MODULE W3IDATMD
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         29-May-2009 |
!/                  +-----------------------------------+
!/
!/    02-Apr-2004 : Origination.                        ( version 3.06 )
!/    19-Jul-2006 : Adding auxiliary grids.             ( version 3.10 )
!/    04-Oct-2006 : Add filter to array pointers.       ( version 3.10 )
!/    29-May-2009 : Preparing distribution version.     ( version 3.14 )
!/
!/    Copyright 2009 National Weather Service (NWS),
!/       National Oceanic and Atmospheric Administration.  All rights
!/       reserved.  WAVEWATCH III is a trademark of the NWS.
!/       No unauthorized use without permission.
!/
!  1. Purpose :
!
!     Define data structures to set up wave model input data for
!     several models simultaneously.
!
!  2. Variables and types :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      NIDATA    Int.  Public   Number of models in array dim.
!      IIDATA    Int.  Public   Selected model for output, init. at -1.
!      INPUT     TYPE  Public   Basic data structure.
!      INPUTS    INPUT Public   Array of data structures.
!     ----------------------------------------------------------------
!
!     All elements of INPUT are aliased to pointers with the same
!     name. Some aditional pointer provide previous equivalenced
!     parameters. These pointers are defined as :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      TLN       I.A.  Public   Time for water level field.
!      TC0/N     I.A.  Public   Times for current fields.
!      TW0/N     I.A.  Public   Times for wind fields.
!      TIN       I.A.  Public   Time for ice field.
!      TnN       I.A.  Public   Time for data types 1-3.
!      TDN       I.A.  Public   Time for next data.
!      TG0/N     I.A.  Public   Times for grid motion data.
!      TFN       I.A.  Public   Array consolidating most above times.
!      GA0/N     Real  Public   Norm of grid speed vector.
!      GD0/N     Real  Public   Direction of grid speed vector.
!      WX0/N     R.A.  Public   Cartesian X and Y wind components
!      WY0/N     R.A.  Public      for both times.
!      DT0/N     R.A.  Public   Corr. air-sea temperature differences.
!      CX0/N     R.A.  Public   Cartesian X and Y current components
!      CY0/N     R.A.  Public      for both times.
!      WLEV      R.A.  Public   Next water level field.
!      ICEI      R.A.  Public   Ice concentrations.
!      IINIT     Log.  Public   Flag for array initialization.
!      HML       R.A.  Public   Mixed layer depth, QL, 150525
!      FLLEV     Log.  Public   Flag for water level input.
!      FLCUR     Log.  Public   Flag for current input.
!      FLWIND    Log.  Public   Flag for wind input.
!      FLICE     Log.  Public   Flag for ice input.
!      FLHML     Log.  Public   Flag for mixed layer depth input.
!                               QL, 150525
!      FLAGS     L.A.  Public   Array consolidating the above four
!                               flags, as well as four additional
!                               data flags.
!     ----------------------------------------------------------------
!
!  3. Subroutines and functions :
!
!      Name      Type  Scope    Description
!     ----------------------------------------------------------------
!      W3NINP    Subr. Public   Set number of grids/models.
!      W3DIMI    Subr. Public   Set dimensions of arrays.
!      W3SETI    Subr. Public   Point to selected grid / model.
!     ----------------------------------------------------------------
!
!  4. Subroutines and functions used :
!
!      Name      Type  Module   Description
!     ----------------------------------------------------------------
!      W3SETG    Subr. W3GDATMD Point to proper model grid.
!      STRACE    Subr. W3SERVMD Subroutine tracing.
!      EXTCDE    Subr. W3SERVMD Abort program with exit code.
!     ----------------------------------------------------------------
!
!  5. Remarks :
!
!     - The number of grids is taken from W3GDATMD, and needs to be
!       set first with W3DIMG.
!
!  6. Switches :
!
!     !/S    Enable subroutine tracing.
!     !/T    Enable test output
!
!  7. Source code :
!
!/ ------------------------------------------------------------------- /
      PUBLIC
!/
!/ Conventional declarations
!/
      INTEGER                 :: NIDATA = -1, IIDATA = -1
!/
!/ Data structure INPUT
!/
      TYPE INPUT
        INTEGER               :: TFN(2,8), TC0(2), TW0(2), TDN(2),    &
                                 TG0(2)
        REAL                  :: GA0, GD0, GAN, GDN
        ! QL, 150525, HML
        REAL, POINTER         :: WX0(:,:), WY0(:,:), DT0(:,:),        &
                                 WXN(:,:), WYN(:,:), DTN(:,:),        &
                                 CX0(:,:), CY0(:,:), CXN(:,:),        &
                                 CYN(:,:), WLEV(:,:), ICEI(:,:),      &
                                 HML(:,:)
        LOGICAL               :: IINIT
        LOGICAL               :: FLAGS(8)
      END TYPE INPUT
!/
!/ Data storage
!/
      TYPE(INPUT), TARGET, ALLOCATABLE :: INPUTS(:)
!/
!/ Data aliasses for structure INPUT(S)
!/
      INTEGER, POINTER        :: TFN(:,:), TLN(:), TC0(:), TCN(:),    &
                                 TW0(:), TWN(:), TIN(:), T0N(:),      &
                                 T1N(:), T2N(:), TDN(:), TG0(:), TGN(:)
      REAL, POINTER           :: GA0, GD0, GAN, GDN
      ! QL, 150525, HML
      REAL, POINTER           :: WX0(:,:), WY0(:,:), DT0(:,:),        &
                                 WXN(:,:), WYN(:,:), DTN(:,:),        &
                                 CX0(:,:), CY0(:,:), CXN(:,:),        &
                                 CYN(:,:), WLEV(:,:), ICEI(:,:),      &
                                 HML(:,:)
      LOGICAL, POINTER        :: IINIT
      LOGICAL, POINTER        :: FLAGS(:)
      ! QL, 150525, FLHML
      LOGICAL, POINTER        :: FLLEV, FLCUR, FLWIND, FLICE, FLHML
!/
      CONTAINS
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3NINP ( NDSE, NDST )
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         19-Jul-2006 !
!/                  +-----------------------------------+
!/
!/    02-Apr-2004 : Origination.                        ( version 3.06 )
!/    19-Jul-2006 : Adding auxiliary grids.             ( version 3.10 )
!/
!  1. Purpose :
!
!     Set up the number of grids to be used.
!
!  2. Method :
!
!     Use data stored in NGRIDS in W3GDATMD.
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       NDSE    Int.   I   Error output unit number.
!       NDST    Int.   I   Test output unit number.
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!     See module documentation.
!
!  5. Called by :
!
!     Any program that uses this grid structure.
!
!  6. Error messages :
!
!     - Error checks on previous setting of variable NGRIDS.
!
!  7. Remarks :
!
!  8. Structure :
!
!  9. Switches :
!
!     !/S    Enable subroutine tracing.
!     !/T    Enable test output
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      USE W3GDATMD, ONLY: NGRIDS, NAUXGR
      USE W3SERVMD, ONLY: EXTCDE
!
      IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      INTEGER, INTENT(IN)     :: NDSE, NDST
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
      INTEGER                 :: I
!/
!
! -------------------------------------------------------------------- /
! 1.  Test input and module status
!
      IF ( NGRIDS .EQ. -1 ) THEN
          WRITE (NDSE,1001) NGRIDS
          CALL EXTCDE (1)
        END IF
!
! -------------------------------------------------------------------- /
! 2.  Set variable and allocate arrays
!
      ALLOCATE ( INPUTS(-NAUXGR:NGRIDS) )
      NIDATA = NGRIDS
!
! -------------------------------------------------------------------- /
! 3.  Initialize parameters
!
      DO I=-NAUXGR, NGRIDS
        INPUTS(I)%TFN(1,:) = -1
        INPUTS(I)%TFN(2,:) =  0
        INPUTS(I)%TC0(1)   = -1
        INPUTS(I)%TC0(2)   =  0
        INPUTS(I)%TW0(1)   = -1
        INPUTS(I)%TW0(2)   =  0
        INPUTS(I)%TDN(1)   = -1
        INPUTS(I)%TDN(2)   =  0
        INPUTS(I)%TG0(1)   = -1
        INPUTS(I)%TG0(2)   =  0
        INPUTS(I)%IINIT    = .FALSE.
        INPUTS(I)%FLAGS    = .FALSE.
        END DO
!
      RETURN
!
! Formats
!
 1001 FORMAT (/' *** ERROR W3NINP : NGRIDS NOT YET SET *** '/         &
               '                    NGRIDS = ',I10/                   &
               '                    RUN W3NMOD FIRST'/)
!
!/
!/ End of W3NINP ----------------------------------------------------- /
!/
      END SUBROUTINE W3NINP
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3DIMI  ( IMOD, NDSE, NDST )
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         04-Oct-2006 !
!/                  +-----------------------------------+
!/
!/    02-Apr-2004 : Origination.                        ( version 3.06 )
!/    19-Jul-2006 : Adding auxiliary grids.             ( version 3.10 )
!/    04-Oct-2006 : Add filter to array pointers.       ( version 3.10 )
!/
!  1. Purpose :
!
!     Initialize an individual data grid at the proper dimensions.
!
!  2. Method :
!
!     Allocate directly into the structure array. Note that
!     this cannot be done through the pointer alias!
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       IMOD    Int.   I   Model number to point to.
!       NDSE    Int.   I   Error output unit number.
!       NDST    Int.   I   Test output unit number.
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!     See module documentation.
!
!  5. Called by :
!
!     Main wave model drivers.
!
!  6. Error messages :
!
!     - Check on input parameters.
!     - Check on previous allocation.
!
!  7. Remarks :
!
!     - W3SETI needs to be called after allocation to point to
!       proper allocated arrays.
!
!  8. Structure :
!
!     See source code.
!
!  9. Switches :
!
!     !/S    Enable subroutine tracing.
!     !/T    Enable test output
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      USE W3GDATMD, ONLY: NGRIDS, NAUXGR, IGRID, W3SETG, NX, NY
      USE W3SERVMD, ONLY: EXTCDE
!
      IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      INTEGER, INTENT(IN)     :: IMOD, NDSE, NDST
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
      INTEGER                 :: JGRID
!/
!
! -------------------------------------------------------------------- /
! 1.  Test input and module status
!
      IF ( NGRIDS .EQ. -1 ) THEN
          WRITE (NDSE,1001)
          CALL EXTCDE (1)
        END IF
!
      IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NIDATA ) THEN
          WRITE (NDSE,1002) IMOD, -NAUXGR, NIDATA
          CALL EXTCDE (2)
        END IF
!
      IF ( INPUTS(IMOD)%IINIT ) THEN
          WRITE (NDSE,1003)
          CALL EXTCDE (3)
        END IF
!
      JGRID  = IGRID
      IF ( JGRID .NE. IMOD ) CALL W3SETG ( IMOD, NDSE, NDST )
!
! -------------------------------------------------------------------- /
! 2.  Allocate arrays
!
      FLLEV  => INPUTS(IMOD)%FLAGS(1)
      FLCUR  => INPUTS(IMOD)%FLAGS(2)
      FLWIND => INPUTS(IMOD)%FLAGS(3)
      FLICE  => INPUTS(IMOD)%FLAGS(4)
      ! QL, 150525, from coupler, set in wav_comp_mct.F90
      FLHML  => INPUTS(IMOD)%FLAGS(5)
!
      IF ( FLLEV  ) ALLOCATE ( INPUTS(IMOD)%WLEV(NX,NY) )
!
      IF ( FLCUR  ) ALLOCATE ( INPUTS(IMOD)%CX0(NX,NY) ,              &
                               INPUTS(IMOD)%CY0(NX,NY) ,              &
                               INPUTS(IMOD)%CXN(NX,NY) ,              &
                               INPUTS(IMOD)%CYN(NX,NY) )
!
      IF ( FLWIND ) ALLOCATE ( INPUTS(IMOD)%WX0(NX,NY) ,              &
                               INPUTS(IMOD)%WY0(NX,NY) ,              &
                               INPUTS(IMOD)%DT0(NX,NY) ,              &
                               INPUTS(IMOD)%WXN(NX,NY) ,              &
                               INPUTS(IMOD)%WYN(NX,NY) ,              &
                               INPUTS(IMOD)%DTN(NX,NY) )
      IF ( FLWIND ) THEN
          INPUTS(IMOD)%DT0 = 0.
          INPUTS(IMOD)%DTN = 0.
      END IF
!
      IF ( FLICE  ) ALLOCATE ( INPUTS(IMOD)%ICEI(NX,NY) )
! QL, 150525, HML from coupler
      IF ( FLHML  ) ALLOCATE ( INPUTS(IMOD)%HML(NX,NY) )
!
      INPUTS(IMOD)%IINIT  = .TRUE.
!
! -------------------------------------------------------------------- /
! 3.  Point to allocated arrays
!
      CALL W3SETI ( IMOD, NDSE, NDST )
!
! -------------------------------------------------------------------- /
! 4.  Update counters in grid
!
! -------------------------------------------------------------------- /
! 5.  Restore previous grid setting if necessary
!
      IF ( JGRID .NE. IMOD ) CALL W3SETG ( JGRID, NDSE, NDST )
!
      RETURN
!
! Formats
!
 1001 FORMAT (/' *** ERROR W3DIMI : GRIDS NOT INITIALIZED *** '/      &
               '                    RUN W3NMOD FIRST '/)
 1002 FORMAT (/' *** ERROR W3DIMI : ILLEGAL MODEL NUMBER *** '/       &
               '                    IMOD   = ',I10/                   &
               '                    NAUXGR = ',I10/                   &
               '                    NIDATA = ',I10/)
 1003 FORMAT (/' *** ERROR W3DIMI : ARRAY(S) ALREADY ALLOCATED *** ')
!
!/
!/ End of W3DIMI ----------------------------------------------------- /
!/
      END SUBROUTINE W3DIMI
!/ ------------------------------------------------------------------- /
      SUBROUTINE W3SETI ( IMOD, NDSE, NDST )
!/
!/                  +-----------------------------------+
!/                  | WAVEWATCH III           NOAA/NCEP |
!/                  |           H. L. Tolman            |
!/                  |                        FORTRAN 90 |
!/                  | Last update :         04-Oct-2006 !
!/                  +-----------------------------------+
!/
!/    02-Apr-2004 : Origination.                        ( version 3.06 )
!/    19-Jul-2006 : Adding auxiliary grids.             ( version 3.10 )
!/    04-Oct-2006 : Add filter to array pointers.       ( version 3.10 )
!/
!  1. Purpose :
!
!     Select one of the WAVEWATCH III grids / models.
!
!  2. Method :
!
!     Point pointers to the proper variables in the proper element of
!     the GRIDS array.
!
!  3. Parameters :
!
!     Parameter list
!     ----------------------------------------------------------------
!       IMOD    Int.   I   Model number to point to.
!       NDSE    Int.   I   Error output unit number.
!       NDST    Int.   I   Test output unit number.
!     ----------------------------------------------------------------
!
!  4. Subroutines used :
!
!     See module documentation.
!
!  5. Called by :
!
!     Any subroutine.
!
!  6. Error messages :
!
!     Many subroutines in the WAVEWATCH system.
!
!  7. Remarks :
!
!  8. Structure :
!
!  9. Switches :
!
!     !/S    Enable subroutine tracing.
!     !/T    Enable test output
!
! 10. Source code :
!
!/ ------------------------------------------------------------------- /
      USE W3GDATMD, ONLY: NAUXGR
!
      USE W3SERVMD, ONLY: EXTCDE
!
      IMPLICIT NONE
!/
!/ ------------------------------------------------------------------- /
!/ Parameter list
!/
      INTEGER, INTENT(IN)     :: IMOD, NDSE, NDST
!/
!/ ------------------------------------------------------------------- /
!/ Local parameters
!/
!/
!
! -------------------------------------------------------------------- /
! 1.  Test input and module status
!
      IF ( NIDATA .EQ. -1 ) THEN
          WRITE (NDSE,1001)
          CALL EXTCDE (1)
        END IF
!
      IF ( IMOD.LT.-NAUXGR .OR. IMOD.GT.NIDATA ) THEN
          WRITE (NDSE,1002) IMOD, -NAUXGR, NIDATA
          CALL EXTCDE (2)
        END IF
!
! -------------------------------------------------------------------- /
! 2.  Set model numbers
!
      IIDATA = IMOD
!
! -------------------------------------------------------------------- /
! 3.  Set pointers
!
      TFN    => INPUTS(IMOD)%TFN
      TC0    => INPUTS(IMOD)%TC0
      TW0    => INPUTS(IMOD)%TW0
      TG0    => INPUTS(IMOD)%TG0
      TDN    => INPUTS(IMOD)%TDN
!
      TLN    => INPUTS(IMOD)%TFN(:,1)
      TCN    => INPUTS(IMOD)%TFN(:,2)
      TWN    => INPUTS(IMOD)%TFN(:,3)
      TIN    => INPUTS(IMOD)%TFN(:,4)
      T0N    => INPUTS(IMOD)%TFN(:,5)
      T1N    => INPUTS(IMOD)%TFN(:,6)
      T2N    => INPUTS(IMOD)%TFN(:,7)
      TGN    => INPUTS(IMOD)%TFN(:,8)
!
      GA0    => INPUTS(IMOD)%GA0
      GD0    => INPUTS(IMOD)%GD0
      GAN    => INPUTS(IMOD)%GAN
      GDN    => INPUTS(IMOD)%GDN
!
      IINIT  => INPUTS(IMOD)%IINIT
      FLAGS  => INPUTS(IMOD)%FLAGS
!
      FLLEV  => INPUTS(IMOD)%FLAGS(1)
      FLCUR  => INPUTS(IMOD)%FLAGS(2)
      FLWIND => INPUTS(IMOD)%FLAGS(3)
      FLICE  => INPUTS(IMOD)%FLAGS(4)
      ! QL, 150525, HML
      FLHML  => INPUTS(IMOD)%FLAGS(5)
!
      IF ( IINIT ) THEN
!
          IF ( FLLEV  ) THEN
              WLEV   => INPUTS(IMOD)%WLEV
            END IF
!
          IF ( FLCUR  ) THEN
              CX0    => INPUTS(IMOD)%CX0
              CY0    => INPUTS(IMOD)%CY0
              CXN    => INPUTS(IMOD)%CXN
              CYN    => INPUTS(IMOD)%CYN
            END IF
!
          IF ( FLWIND  ) THEN
              WX0    => INPUTS(IMOD)%WX0
              WY0    => INPUTS(IMOD)%WY0
              DT0    => INPUTS(IMOD)%DT0
              WXN    => INPUTS(IMOD)%WXN
              WYN    => INPUTS(IMOD)%WYN
              DTN    => INPUTS(IMOD)%DTN
            END IF
!
          IF ( FLICE  ) THEN
              ICEI   => INPUTS(IMOD)%ICEI
            END IF
! QL, 150525, HML
          IF ( FLHML  ) THEN
              HML    => INPUTS(IMOD)%HML
            END IF
!
        END IF
!
      RETURN
!
! Formats
!
 1001 FORMAT (/' *** ERROR W3SETI : GRIDS NOT INITIALIZED *** '/      &
               '                    RUN W3NMOD FIRST '/)
 1002 FORMAT (/' *** ERROR W3SETI : ILLEGAL MODEL NUMBER *** '/       &
               '                    IMOD   = ',I10/                   &
               '                    NAUXGR = ',I10/                   &
               '                    NIDATA = ',I10/)
!
!/
!/ End of W3SETI ----------------------------------------------------- /
!/
      END SUBROUTINE W3SETI
!/
!/ End of module W3IDATMD -------------------------------------------- /
!/
      END MODULE W3IDATMD


ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c   subroutine dosymops applies symops to the assymetric unit atoms
c      input to it, outputs a list of unique atoms defining the
c      molecule, surface or crystal. it also sorts them by name
c
c                                       3/1/94 A.C. Hess
c
c
c   some variables:
c       coords = input coordinates of atoms in assymetric unit
c        nata = number of atoms in assymtric unit
c       coord = full coordinate list of all atoms
c         nat = total number of atoms
c      ipcord = pointer before the first empty spot in coord
c        xnew = array holds atoms generated for a given assym atoms
c               for the list of entire list of symops, 4th colum is
c               used in an in place comparison of atoms to determine
c               uniqueness
c iasym_order = keeps track of where the original assymetric unit
c               atoms are in the final (full) coordinate list.
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine dosymops(symops,nops,coords,tags,nata,itype,
     &     tags_new,coords_new,nareal,nat,cdist,cang,iasym_order,
     $     charge, charge_new, mass, mass_new,
     $     threquiv,ierr)
C$Id: dosymops.f 22595 2012-04-09 17:15:09Z ecce_cm $
*rak typed everyting
      implicit none
c
      double precision tol, threquiv
      integer maxops, iodat
      parameter (maxops=192,iodat=11)
c
      integer nata, nat, ierr
      integer nops, itype, nareal
      character*16 tags(nata),tags_new(nat)
      double precision symops(maxops*3,4),coords_new(3,nat),
     &    xnew(maxops,4),
     &    coords(3,nata),cdist(3),cang(3)
      integer iasym_order(nata)
      double precision charge(*), charge_new(*), mass(*),
     $     mass_new(*)
c
      integer i, j, k, l, ii, ll, nata_old,
     &    ipcord, ipt, nauniq, iopnum, im, iop
      double precision sum, dx, dy, dz, x, y, z
c
c     set tolerance
c
      ierr = 0
      tol = threquiv
      nata_old = nata
c
c     Modified below (RJH) so that can send in a list with symmetry
c     equivalent atoms and not generate redundant ones and also
c     identify the unique ones correctly
c
c--> application of symops to atoms in assym. unit
c-->
c--> outer loops go: 1)over all atoms, 2) over the number of symops
c--> 3) mult. current symop times current atom coordinates. Done for
c--> all symops for a given atom, 4) the list is then sorted, and the
c--> unique atoms added to the master list.
c
c--> if its a fractional system move all atoms into cell before application
c--> of symops. still no 1-d systems
c
c bulk
c
      if(itype.eq.3) then
        do 900 i=1,nata
          do 910 j=1,3
 2000       if(coords(j,i).lt.(0.0d+00)) then
              coords(j,i)=coords(j,i)+1.0d+00
              goto 2000
            elseif (coords(j,i).ge.1.0d+00) then
              coords(j,i)=coords(j,i)-1.0d+00
              goto 2000
            endif
            if(dabs(coords(j,i)) .lt. 1.0d-10) then
              coords(j,i) = 0.0d+00
            endif
            if(dabs(dabs(coords(j,i))-1.0d+00) .lt. 1.0d-10) then
              coords(j,i) = 0.0d+00
            endif
  910     continue
  900   continue
c surfaces
      elseif(itype.eq.2) then
         do 902 i=1,nata
            do 912 j=1,2
 2002          if(coords(j,i).lt.0.0d+00) then
                  coords(j,i)=coords(j,i)+1.0d+00
                  goto 2002
               elseif (coords(j,i).ge.1.0d+00) then
                  coords(j,i)=coords(j,i)-1.0d+00
                  goto 2002
               endif
               if(dabs(coords(j,i)) .lt. 1.0d-10) then
                 coords(j,i) = 0.0d+00
               endif
               if(dabs(dabs(coords(j,i))-1.0d+00) .lt. 1.0d-10) then
                 coords(j,i) = 0.0d+00
               endif
 912        continue
 902     continue
c
      elseif(itype.eq.1) then
         do 904 i=1,nata
            j = 3
 2004          if(coords(j,i).lt.0.0d+00) then
                  coords(j,i)=coords(j,i)+1.0d+00
                  goto 2004
               elseif (coords(j,i).ge.1.0d+00) then
                  coords(j,i)=coords(j,i)-1.0d+00
                  goto 2004
               endif
               if(dabs(coords(j,i)) .lt. 1.0d-10) then
                 coords(j,i) = 0.0d+00
               endif
               if(dabs(dabs(coords(j,i))-1.0d+00) .lt. 1.0d-10) then
                 coords(j,i) = 0.0d+00
               endif
 904     continue
c
      endif
c
c symops*coordinates
c
      ipcord=0
      nareal=0
      sum=0.0d+00
      ipt=nops+1
      nauniq = 0
c
      do 300 i=1,nata
c
c     Check to see if the atom is already present
c
         do l=1,ipcord
            dx=dabs(coords(1,i)-coords_new(1,l))
            dy=dabs(coords(2,i)-coords_new(2,l))
            dz=dabs(coords(3,i)-coords_new(3,l))
            if(dx+dy+dz.le.3*tol) then
            endif
         enddo
 543     format(a,2i4,3f12.6)
 544     format(a,i4,3f12.6)
         iopnum=0
c
c--> reset flag for atom uniqueness
c
         do 570 im=1,nops
            xnew(im,4)=0.0
570      continue
         do 305 iop=1,nops
            do 310 j=1,3
               iopnum=iopnum+1
               do 320 k=1,3
                  sum=sum+symops(iopnum,k)*coords(k,i)
320            continue
               xnew(iop,j)=sum+symops(iopnum,4)
               sum=0.0d+00
310         continue
c
c--> shift it into the home cell. This operation depends on sysytem type
c--> in place for 3-d,2-d and molecules now.
c
            if(itype.eq.3) then ! bulk
 3000         do 380 ii=1,3
                if(dabs(xnew(iop,ii)).lt.1.0d-10) then
                  xnew(iop,ii)=0.0d0
                endif
                if(dabs((dabs(xnew(iop,ii))-1.0d0)).lt.1.0d-10) then
                   xnew(iop,ii)=0.0d0
                endif
                if(xnew(iop,ii).lt.(0.0d0)) then
                  xnew(iop,ii)=xnew(iop,ii)+1.0d0
                  goto 3000
                elseif (xnew(iop,ii).ge.1.0d0) then
                  xnew(iop,ii)=xnew(iop,ii)-1.0d0
                  goto 3000
                endif
  380         continue
            elseif(itype.eq.2) then ! surfaces
 3020         do 382 ii=1,2
                if(dabs(xnew(iop,ii)).lt.1.0d-10) then
                  xnew(iop,ii)=0.0d0
                endif
                if(dabs((dabs(xnew(iop,ii))-1.0d0)).lt.1.0d-10) then
                   xnew(iop,ii)=0.0d0
                endif
                if(xnew(iop,ii).lt.0.0d0) then
                  xnew(iop,ii)=xnew(iop,ii)+1.0d0
                  goto 3020
                elseif (xnew(iop,ii).ge.1.0d0) then
                  xnew(iop,ii)=xnew(iop,ii)-1.0d0
                  goto 3020
                endif
 382         continue
            endif
  305     continue
c
c--> place this assym. atom into final coord list
c
         ipcord=ipcord + 1
         nauniq = nauniq + 1
         nareal = nareal + 1
         do 330 ll=1,3
            coords_new(ll,ipcord)=coords(ll,i)
330      continue
         tags_new(ipcord)=tags(i)
         charge_new(ipcord)=charge(i)
         mass_new(ipcord)=mass(i)
         iasym_order(nauniq)=ipcord
*
*rak: changed K -> i  was that right?
*
c
c--> remove copies of the assymetric atom from the xnew list
c
         x=coords(1,i)
         y=coords(2,i)
         z=coords(3,i)
         do 390 l=1,nops
               dx=dabs(x-xnew(l,1))
               dy=dabs(y-xnew(l,2))
               dz=dabs(z-xnew(l,3))
               if(dx.le.tol.and.dy.le.tol.and.dz.le.tol) then
                  xnew(l,4)=1.0d0
               endif
390      continue
c
c--> sift the xnew list for unique atoms
c
         do 400 k=1,nops
            if(xnew(k,4).ne.1.0d0) then
               x=xnew(k,1)
               y=xnew(k,2)
               z=xnew(k,3)
               do 410 l=k+1,nops
                  dx=dabs(x-xnew(l,1))
                  dy=dabs(y-xnew(l,2))
                  dz=dabs(z-xnew(l,3))
                  if(dx.le.tol.and.dy.le.tol.and.dz.le.tol) then
                     xnew(l,4)=1.0d0
                  endif
410            continue
            endif
400      continue
c
c--> put the new unique atoms into the final list, keeping track of
c--> what kind they are.
c
         do 420 k=1,nops
            if(xnew(k,4).ne.1.0d0) then
               ipcord=ipcord+1
               nareal=nareal+1
               do 430 ll=1,3
                  coords_new(ll,ipcord)=xnew(k,ll)
430            continue
               tags_new(ipcord)=tags(i)
               charge_new(ipcord)=charge(i)
               mass_new(ipcord)=mass(i)
            endif
420      continue
300   continue
c
      nata = nauniq
*
*     RJH.  If the user input all of the atoms don't want
*     to reorder them since it may break zmatrix/autoz
*
      if (itype.eq.0 .and. nareal.eq.nata_old) then
c
c     Map unique atoms back into old ordering
c
         do ii = 1, nauniq
            i = iasym_order(ii)
            do j = 1, nareal
               dx = abs(coords_new(1,i) - coords(1,j))
               dy = abs(coords_new(2,i) - coords(2,j))
               dz = abs(coords_new(3,i) - coords(3,j))
               if(dx.le.tol.and.dy.le.tol.and.dz.le.tol) then
                  iasym_order(ii) = j
                  goto 9876
               endif
            enddo
 9876       continue
         enddo
         do i = 1, nareal
            tags_new(i) = tags(i)
         enddo
         call dcopy(nareal, charge, 1, charge_new, 1)
         call dcopy(nareal, mass, 1, mass_new, 1)
         call dcopy(nareal*3, coords, 1, coords_new, 1)
      endif
c
c
c--> write stuff out
c
c--> coordinate output stuff
c
c     if(itype.ne.0) then
c        write(*,13)
c        if(itype.eq.3) then
c           write(*,28)
c           write(*,29)
c        elseif(itype.eq.2) then
c           write(*,32)
c           write(*,31)
c        elseif(itype.eq.1) then
c           write(*,33)
c           write(*,34)
c        endif
c        write(*,14)
c        call wrcell(cdist,cang,itype)
c
c--   > list of atoms in assymetric unit
c
c        write(*,10) nata
c        do 500 i=1,nata
c           write(*,20) i,tags(i),(coords(j,i),j=1,3)
c500     continue
c
c--> list of total number of atoms unit cell of the solid
c
c        write(*,25) nareal
c        do 510 i=1,nareal
c           write(*,20) i,tags_new(i),(coord(j,i),j=1,3)
c510     continue
c     endif
c
10    format(/,22x,i5,6x,'SYMMETRY DISTINCT ATOMS',/)
13    format(///,'--------------------- PERIODIC SYSTEM GEOMETRY INFORMA
     $TION',' -------------------',/)
 14   format(/,'------------------------------------------------------',
     &'-----------------------',/)
 20   format(10x,i5,2x,a16,3f14.8)
 25   format(//,22x,i5,6x,'ATOMS IN UNIT CELL',/)
 28   format(28X,'SYSTEM TYPE = BULK CRYSTAL',/)
 29   format(25x,' FRACTIONAL ATOMIC COORDINATES ')
 30   format(/,15x,'-------------- ATOMIC COORDINATES --------------',/)
 31   format(6x,'FRACTIONAL & CARTESIAN COORDINATES: Z-COMPONENT UNITS =
     $ANGSTROMS')
 32   format(29x,'SYSTEM TYPE = SURFACE',/)
 33   format(29x,'SYSTEM TYPE = POLYMER',/)
 34   format(5x,'FRACTIONAL & CARTESIAN COORDINATES: XY-COMPONENTS IN UN
     $ITS = ANGSTROMS')
c
      end
c
      subroutine  dcopy(n,dx,incx,dy,incy)
*
* $Id: dosymops.f 22595 2012-04-09 17:15:09Z ecce_cm $
*
c
c     copies a vector, x, to a vector, y.
c     uses unrolled loops for increments equal to one.
c     jack dongarra, linpack, 3/11/78.
c     modified 12/3/93, array(1) declarations changed to array(*)
c
      double precision dx(*),dy(*)
      integer i,incx,incy,ix,iy,m,mp1,n
c
      if(n.le.0)return
      if(incx.eq.1.and.incy.eq.1) goto 20
c
c        code for unequal increments or equal increments
c          not equal to 1
c
      ix = 1
      iy = 1
      if(incx.lt.0)ix = (-n+1)*incx + 1
      if(incy.lt.0)iy = (-n+1)*incy + 1
      do 10 i = 1,n
        dy(iy) = dx(ix)
        ix = ix + incx
        iy = iy + incy
   10 continue
      return
c
c        code for both increments equal to 1
c
c
c        clean-up loop
c
   20 m = mod(n,7)
      if( m .eq. 0 ) goto 40
      do 30 i = 1,m
        dy(i) = dx(i)
   30 continue
      if( n .lt. 7 ) return
   40 mp1 = m + 1
      do 50 i = mp1,n,7
        dy(i) = dx(i)
        dy(i + 1) = dx(i + 1)
        dy(i + 2) = dx(i + 2)
        dy(i + 3) = dx(i + 3)
        dy(i + 4) = dx(i + 4)
        dy(i + 5) = dx(i + 5)
        dy(i + 6) = dx(i + 6)
   50 continue
      return
      end


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!!  EXTRACT_NETWORK -- Extract the material interface network.
!!
!!      CALL EXTRACT_NETWORK (CMOOUT, CMOIN, MASK, IERROR)
!!
!!    This routine extracts the material interface network from a multimaterial
!!    mesh to create a new mesh object.  In contrast to other interface
!!    extraction routines that extract the "child interface" on one (or both)
!!    sides of the interface, this routine extracts the "parent interface".
!!    Because of the nature of this extraction, not all attributes in the output
!!    mesh object are given values.  Among the array-valued attributes, only
!!    XIC, YIC, ZIC, ITET, ITETOFF, ITETTYP, and ICR1 are set.  In particular
!!    JTET is not set, because it is possible, in general, for more than two
!!    cells to share a face in a network.  The ICONTAB array is copied from the
!!    input mesh object to the output mesh object.
!!
!!    The output mesh object is given an additional node-based attribute named
!!    "map" which provides the mapping from nodes in the extracted interface
!!    network to (parent) nodes in the input mesh object; that is, MAP(J) is
!!    the parent node in the input mesh object that corresponds to node J in
!!    the output mesh object.
!!
!!  INPUT ARGUMENTS
!!
!!    CMOOUT -- Output mesh object name.
!!    CMOIN  -- Input mesh object name.
!!    MASK   -- Node mask.  Currently ignored!  All nodes are considered.
!!
!!  OUTPUT ARGUMENTS
!!
!!    IERROR -- Error flag
!!
!!  CHANGE HISTORY --
!!
c$Log: extract_network.f,v $
cRevision 2.00  2007/11/05 19:45:54  spchu
cImport to CVS
c
CPVCS
CPVCS       Rev 1.2   05 May 2000 15:12:16   dcg
CPVCS    refresh mbndry value after cmo_newlen
CPVCS
CPVCS       Rev 1.1   Mon Nov 30 11:03:02 1998   nnc
CPVCS    Added documentation.
CPVCS
CPVCS       Rev 1.0   Thu Nov 05 12:55:48 1998   dcg
CPVCS    Initial revision.
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

      subroutine extract_network (cmoout, cmoin, mask, ierror)
      implicit none

      character*(*) cmoout, cmoin
      integer mask(*), ierror

      include "local_element.h"

      !! Define the element type associated with each element face.  It is
      !! purely coincidental that the number of points on a face is the same
      !! as the face element type.  (Move into local_element.h/blockcom.f?)

      integer ifacetype(maxnef,nelmtypes)
      data ifacetype / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     *                 1, 1, 0, 0, 0, 0, 0, 0, 0, 0,
     *                 2, 2, 2, 0, 0, 0, 0, 0, 0, 0,
     *                 2, 2, 2, 2, 0, 0, 0, 0, 0, 0,
     *                 3, 3, 3, 3, 0, 0, 0, 0, 0, 0,
     *                 4, 3, 3, 3, 3, 0, 0, 0, 0, 0,
     *                 3, 3, 4, 4, 4, 0, 0, 0, 0, 0,
     *                 4, 4, 4, 4, 4, 4, 0, 0, 0, 0,
     *                 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     *                 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
     *               /

      pointer (ipxic,xic), (ipyic,yic), (ipzic,zic)
      real*8 xic(*), yic(*), zic(*)

      pointer (ipitet,itet), (ipitetoff,itetoff), (ipitettyp,itettyp),
     &        (ipjtet,jtet), (ipjtetoff,jtetoff), (ipitetclr,itetclr),
     &        (ipitp1,itp1), (ipisn1,isn1), (ipicr1,icr1),
     &        (ipicontab,icontab)
      integer itet(*), jtet(*), itetoff(*), jtetoff(*), itettyp(*),
     &        itetclr(*), itp1(*), isn1(*), icr1(*), icontab(*)

      pointer (ipxicn,xicn), (ipyicn,yicn), (ipzicn,zicn)
      real*8 xicn(*), yicn(*), zicn(*)

      pointer (ipitetn,itetn), (ipitetoffn,itetoffn), (ipcpmap,cpmap),
     &        (ipitettypn,itettypn), (ipicr1n,icr1n), (ipfmap,fmap),
     &        (ipicontabn,icontabn), (ipmap,map)
      integer itetn(*), itetoffn(*), itettypn(*), icr1n(*),
     &        icontabn(*), map(*), cpmap(*), fmap(*)

      integer i, j, k, m, n, ilen, ityp, nnnpe, nnfpe, nnepe, jnbr
      integer nncells, nnnodes, minft, maxft, nfpe, nconbnd, node
      integer nnodes, ncells, topo_dim, geom_dim, mbndry, ncon50

      character*132 cbuf, logmess
      character*32 isubname

      isubname = 'extract_network'
      ierror = 0

     !!!
     !!! Get the attributes from the input mesh object.

      call cmo_get_info('ndimensions_topo',cmoin,topo_dim,ilen,ityp,
     &                                                           ierror)
      call cmo_get_info('ndimensions_geom',cmoin,geom_dim,ilen,ityp,
     &                                                           ierror)
      call cmo_get_info('nelements',cmoin,ncells,ilen,ityp,ierror)
      call cmo_get_info('nnodes',cmoin,nnodes,ilen,ityp,ierror)
      call cmo_get_info('faces_per_element',cmoin,nfpe,ilen,ityp,ierror)
      call cmo_get_info('mbndry',cmoin,mbndry,ilen,ityp,ierror)
      call cmo_get_info('itet',cmoin,ipitet,ilen,ityp,ierror)
      call cmo_get_info('jtet',cmoin,ipjtet,ilen,ityp,ierror)
      call cmo_get_info('itetoff',cmoin,ipitetoff,ilen,ityp,ierror)
      call cmo_get_info('jtetoff',cmoin,ipjtetoff,ilen,ityp,ierror)
      call cmo_get_info('itetclr',cmoin,ipitetclr,ilen,ityp,ierror)
      call cmo_get_info('itettyp',cmoin,ipitettyp,ilen,ityp,ierror)
      call cmo_get_info('itp1',cmoin,ipitp1,ilen,ityp,ierror)
      call cmo_get_info('isn1',cmoin,ipisn1,ilen,ityp,ierror)
      call cmo_get_info('icr1',cmoin,ipicr1,ilen,ityp,ierror)
      call cmo_get_info('xic',cmoin,ipxic,ilen,ityp,ierror)
      call cmo_get_info('yic',cmoin,ipyic,ilen,ityp,ierror)
      call cmo_get_info('zic',cmoin,ipzic,ilen,ityp,ierror)

     !!!
     !!! Preliminary pass through the cells, counting faces and nodes.

      call mmgetblk ('cpmap', isubname, ipcpmap, nnodes, 1, ierror)
      call mmgetblk ( 'fmap', isubname,  ipfmap, nnodes, 1, ierror)
      call unpackpc (nnodes, itp1, isn1, cpmap)
      do j = 1, nnodes
        fmap(j) = 0
      end do

      nncells = 0
      nnnodes = 0
      minft = nelmtypes
      maxft = 0

      do j = 1, ncells
        do k = 1, nelmnef(itettyp(j))
          if (jtet(k+jtetoff(j)) .gt. mbndry) then
            jnbr = 1 + (jtet(k+jtetoff(j)) - mbndry - 1) / nfpe
            if (itetclr(jnbr) .gt. itetclr(j)) then
              nncells = nncells + 1
              minft = min( ifacetype(k,itettyp(j)), minft )
              maxft = max( ifacetype(k,itettyp(j)), maxft )
              do i = 1, ielmface0(k,itettyp(j))
                node = cpmap(itet(itetoff(j)+ielmface1(i,k,itettyp(j))))
                if (fmap(node) .eq. 0) then
                  nnnodes = nnnodes + 1
                  fmap(node) = nnnodes
                end if
              end do
            end if
          end if
        end do
      end do

      if (nncells .eq. 0) then
        logmess = 'Input mesh object has no material interfaces.'
        call writloga ('default', 0, logmess, 0, ierror)
        return
      end if

      !! Determine the type of the extracted mesh.
      if (minft.eq.ifelmlin .and. maxft.eq.ifelmlin) then
        nnnpe = nelmnen(ifelmlin)
        nnfpe = nelmnef(ifelmlin)
        nnepe = nelmnee(ifelmlin)
      else if (minft.eq.ifelmtri .and. maxft.eq.ifelmtri) then
        nnnpe = nelmnen(ifelmtri)
        nnfpe = nelmnef(ifelmtri)
        nnepe = nelmnee(ifelmtri)
      else if (minft.eq.ifelmqud .and. maxft.eq.ifelmqud) then
        nnnpe = nelmnen(ifelmqud)
        nnfpe = nelmnef(ifelmqud)
        nnepe = nelmnee(ifelmqud)
      else if (minft.eq.ifelmtri .and. maxft.eq.ifelmqud) then
        nnnpe = nelmnen(ifelmhyb)
        nnfpe = nelmnef(ifelmhyb)
        nnepe = nelmnee(ifelmhyb)
      else
        logmess = 'EXTRACT_NETWORK: PANIC!  bad minft/maxft values.'
        call writloga ('default', 0, logmess, 0, ierror)
        stop
      end if

     !!!
     !!! Create the output mesh object

      call cmo_exist (cmoout, ierror)
      if (ierror .eq. 0) call cmo_release (cmoout, ierror)
      call cmo_create (cmoout, ierror)

      call cmo_set_info('nnodes',cmoout,nnnodes,1,1,ierror)
      call cmo_set_info('nelements',cmoout,nncells,1,1,ierror)
      call cmo_set_info('ndimensions_topo',cmoout,topo_dim-1,1,1,ierror)
      call cmo_set_info('ndimensions_geom',cmoout,geom_dim,1,1,ierror)
      call cmo_set_info('nodes_per_element',cmoout,nnnpe,1,1,ierror)
      call cmo_set_info('faces_per_element',cmoout,nnfpe,1,1,ierror)
      call cmo_set_info('edges_per_element',cmoout,nnepe,1,1,ierror)

      call cmo_newlen (cmoout, ierror)

      call cmo_get_intinfo('mbndry',cmoin,mbndry,ilen,ityp,ierror)
      call cmo_get_info('itet',cmoout,ipitetn,ilen,ityp,ierror)
      call cmo_get_info('itetoff',cmoout,ipitetoffn,ilen,ityp,ierror)
      call cmo_get_info('itettyp',cmoout,ipitettypn,ilen,ityp,ierror)
      call cmo_get_info('icr1',cmoout,ipicr1n,ilen,ityp,ierror)
      call cmo_get_info('xic',cmoout,ipxicn,ilen,ityp,ierror)
      call cmo_get_info('yic',cmoout,ipyicn,ilen,ityp,ierror)
      call cmo_get_info('zic',cmoout,ipzicn,ilen,ityp,ierror)

      !! Add the output->input node mapping as an attribute of the
      !! output mesh object.
      cbuf = "cmo/addatt/" // cmoout //
     &       "/map/vint/scalar/nnodes////0; finish"
      call dotaskx3d (cbuf, ierror)
      call cmo_get_info ("map", cmoout, ipmap, ilen, ityp, ierror)
      do j = 1, nnodes
        if (fmap(j) .gt. 0) then
          map(fmap(j)) = j
        end if
      end do

     !!!
     !!! Second pass through the cells.

      n = 0
      m = 0

      do j = 1, ncells
        do k = 1, nelmnef(itettyp(j))
          if (jtet(k+jtetoff(j)) .gt. mbndry) then
            jnbr = 1 + (jtet(k+jtetoff(j)) - mbndry - 1) / nfpe
            if (itetclr(jnbr) .gt. itetclr(j)) then
              n = n + 1
              itettypn(n) = ifacetype(k,itettyp(j))
              itetoffn(n) = m
              m = m + nelmnen(itettypn(n))
              do i = 1, ielmface0(k,itettyp(j))
                node = cpmap(itet(itetoff(j)+ielmface1(i,k,itettyp(j))))
                itetn(itetoffn(n)+i) = fmap(node)
              end do
            end if
          end if
        end do
      end do

     !!!
     !!! Copy node-based data into new mesh object.

      if (geom_dim .eq. 2) then

        do j = 1, nnnodes
          xicn(j) = xic(map(j))
          yicn(j) = yic(map(j))
          icr1n(j) = icr1(map(j))
        end do

      else if (geom_dim .eq. 3) then

        do j = 1, nnnodes
          xicn(j) = xic(map(j))
          yicn(j) = yic(map(j))
          zicn(j) = zic(map(j))
          icr1n(j) = icr1(map(j))
        end do

      end if

      !! NOTE.  The following node-based attributes are left uninitialized:
      !! ialias, imt1, itp1, isn1, ign1.  The following cell-based attributes
      !! are left uninitialized: itetclr, jtet, jtetoff.

     !!!
     !!! Copy the constraint table into the new mesh object.

      cbuf = 'cmo/addatt/' // cmoout //
     &       '/ncon50/int/scalar/scalar/constant/permanent/x/0; finish'
      call dotaskx3d (cbuf, ierror)
      call cmo_get_info ('ncon50',cmoin,  ncon50, ilen,ityp,ierror)
      call cmo_set_info ('ncon50',cmoout, ncon50, i,1,ierror)

      cbuf = 'cmo/addatt/' // cmoout //
     &       '/nconbnd/int/scalar/scalar/constant/permanent/x/0; finish'
      call dotaskx3d (cbuf, ierror)
      call cmo_get_info ('nconbnd',cmoin,  nconbnd, ilen,ityp,ierror)
      call cmo_set_info ('nconbnd',cmoout, nconbnd, 1,1,ierror)

      cbuf = 'cmo/addatt/' // cmoout //
     &     '/icontab/vint/scalar/ncon50/constant/permanent/x/0; finish'
      call dotaskx3d (cbuf, ierror)
      call cmo_get_info ('icontab',cmoin,  ipicontab,  ilen,ityp,ierror)
      call cmo_get_info ('icontab',cmoout, ipicontabn, ilen,ityp,ierror)
      do j = 1, ncon50
       icontabn(j) = icontab(j)
      end do

      call mmrelprt(isubname,ierror)

      return
      end


! <filter_areas.for - A component of the City-scale
!                 Chemistry Transport Model EPISODE-CityChem>
!*****************************************************************************!
!*
!*        CITY-scale CHEMistry Transport Extension
!*
!*        Copyright (C) 2018  Matthias Steffen Karl
!*
!*        Contact Information:
!*            Institute of Coastal Research
!*            Helmholtz-Zentrum Geesthacht
!*            Max-Planck-Str. 1
!*            21502 Geesthacht
!*            Germany
!*            email:  matthias.karl@hzg.de
!*
!*      EPISODE-CityChem, developed at Helmholtz-Zentrum Geesthacht (HZG) is designed
!*      for treating complex atmospheric chemistry in urban areas (Karl, 2018). The model
!*      is an extension of the EPISODE dispersion model to enable chemistry/transport
!*      simulations of reactive pollutants on city scale. EPISODE is an Eulerian dispersion
!*      model developed at the Norwegian Institute for Air Research (NILU) appropriate for
!*      air quality studies at the local scale (Slørdal et al. 2003 &2008). The model is an
!*      open source code subject to the Reciprocal Public License ("RPL") Version 1.5,
!*      https://opensource.org/licenses/RPL-1.5.
!*
!*        Reference:
!*      Karl, M. (2018):  Development of the city-scale chemistry transport model
!*      CityChem-EPISODE and its application to the city of Hamburg,
!*      Geosci. Model Dev. Discuss.,
!*      https://doi.org/10.5194/gmd-2018-8, 2018.
!*
!*
!*  Unless explicitly acquired and licensed from Licensor under another license,
!*  the contents of this file are subject to the Reciprocal Public License ("RPL")
!*  Version 1.5, https://opensource.org/licenses/RPL-1.5 or subsequent versions as
!*  allowed by the RPL, and You may not copy or use this file in either source code
!*  or executable form, except in compliance with the terms and conditions of the RPL.
!*
!*  All software distributed under the RPL is provided strictly on an "AS IS" basis,
!*  WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, AND LICENSOR HEREBY
!*  DISCLAIMS ALL SUCH WARRANTIES, INCLUDING WITHOUT LIMITATION, ANY WARRANTIES OF
!*  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, QUIET ENJOYMENT, OR NON-INFRINGEMENT.
!*  See the RPL for specific language governing rights and limitations under the RPL.
!*
!*****************************************************************************!
!
!***********************************************************************
!***
!***      UECT
!***      Urban Emission Conversion Tool
!***
!***********************************************************************

      subroutine filter_areas(incols,nareas,nhours,          &
                           snap,data_array,nareas_new,       &
                           filter_snap,filter_xi,filter_yi,  &
                           filter_array)

!***********************************************************************
!***  Subroutine filters area sources.
!***  First step is to produce a mask for the domain with the
!***  TestClosestPair program.
!***  Second step is to filter the area sources indicated as
!***  being outside the model domain
!***  The routine also does an aggregation of smaller area parts
!***  into the model grid cells.
!***********************************************************************

!     Declarations of variables by using the MODULES feature:

      use module_uect_exe
      use module_uect_emis
      use module_uect_io

      use Closest_Pair

      implicit none

!***********************************************************************

!in
      integer, intent(in)             :: incols
      integer, intent(in)             :: nareas
      integer, intent(in)             :: nhours
      integer, dimension(nareas),intent(in)      :: snap
      real, dimension(nareas,incols),intent(in)  :: data_array
!out
      integer, dimension(nareas),intent(out)     :: filter_snap
      real, dimension(nareas,incols),intent(out) :: filter_array
      integer, dimension(nareas), intent(out)    :: filter_xi
      integer, dimension(nareas), intent(out)    :: filter_yi
      integer, intent(out)                       :: nareas_new

!     Local declarations:

      integer            :: n,k
      integer            :: i,ix,iy
      integer            :: t
      integer            :: ai1,ai2
      integer            :: lenc

      real               :: xcor_start,xcor_end
      real               :: ycor_start,ycor_end
      real               :: dp,dr
      real               :: limd

      type(point), dimension(:), allocatable :: points

      type(point), dimension(2) :: p

      integer,dimension(nareas) :: aind
      integer,dimension(nareas) :: xi
      integer,dimension(nareas) :: yi

!***********************************************************************
!     Content of subroutine:

! ***  PART 1

! *** Set the extent of the model domain
! *** Add a buffer dxarea (TAPM point distance m)

       !!! Grid origo is SW corner !!!
       ! W border in UTM m
       borderw = sitex0 - dxarea
       ! S border in UTM m
       borders = sitey0 - dxarea
       ! E border in UTM m
       bordere = sitex0 + dxout*n_nx + dxarea
       ! N border in UTM m
       bordern = sitey0 + dxout*n_ny + dxarea

       !print *,'filter borders', borderw,borders,bordere,borderw

! ***   dxout is EPISODE grid distance dx m
       limd = dxout + dxout/5

       !print *,'test', borderw,borders,bordere,bordern,limd

! ***   ALLOCATE
       if (.not. allocated(points))      allocate( points(n_nx*n_ny+1) )

! ***  Construct the CityChem model grid, point by point
! ***  and write into points pair array

       i = 1
       do ix = 1, n_nx
         do iy = 1, n_ny
           points(i)%x = sitex0 + (ix-1)*dxout
           points(i)%y = sitey0 + (iy-1)*dxout
           !print *,i, points(i)
           i = i + 1
         enddo
       enddo

! ***   now read the grid points from input "area_src_file" file
       do t = 1, n_soaa

! ***   check x-coordinates of the area source
           if ( (data_array(t,1)>1.e6).or.(data_array(t,4)>1.e6) ) then
             call stopit('Area source UTM x-coordinate has to be without leading digits for UTM zone')
           endif

           aind(t) = 0

           ! Mid-Point coordinate
           points(n_nx*n_ny+1)%x = data_array(t,1) + 0.5*dxarea

           points(n_nx*n_ny+1)%y = data_array(t,2) + 0.5*dxarea

           print *, "new point", points(n_nx*n_ny+1)

! *** exclude the point if outside of the model domain
           if ( (points(n_nx*n_ny+1)%x .lt. borderw ) .or. &
                (points(n_nx*n_ny+1)%x .gt. bordere ) .or. &
                (points(n_nx*n_ny+1)%y .lt. borders ) .or. &
                (points(n_nx*n_ny+1)%y .gt. bordern )         ) then

              aind(t) = 0

           else

             ! Simple closest pair works best for this purpose
             dp = closest_pair_simple(points, p)
             !print *, "sim ", dp

             if (dp .le. limd) then

               ai1 = 0
               ai2 = 0
               do i = 1, (n_nx*n_ny)
                 if ((p(1)%x.eq.points(i)%x).and.(p(1)%y.eq.points(i)%y)) then
                   ai1=i
                 endif
                 if ((p(2)%x.eq.points(i)%x).and.(p(2)%y.eq.points(i)%y)) then
                   ai2=i
                 endif
               end do
               if (  (ai1>0).and.(ai2>0).and.(ai1.ne.ai2) ) then   ! error
                 print *,"WARNING: two different indices ai1 ai2: ",ai1,ai2
                 print *,"p ",p(1)%x,p(1)%y,p(2)%x,p(2)%y
                 print *,"Point will not be included."
                 if (fe_log) then
                   write(funit_log,'(1X,A56,I5,I5)')  &
                   'Warning: two different indices ai1 ai2: ',ai1,ai2
                   write(funit_log,'(1X,A56,1X,I5,4F11.1)')  &
                   'Point will not be included: ',t,p(1)%x,p(1)%y,p(2)%x,p(2)%y
                 endif
                 aind(t) = 0
               else
                 if (ai1>0) aind(t)=ai1
                 if (ai2>0) aind(t)=ai2
               endif

!*** point somewhere close but outside
             else
                print *,"Point not close enough to any grid cell:"
                print *, t,  dp, points(n_nx*n_ny+1)%x, points(n_nx*n_ny+1)%y
                 if (fe_log) then
                   write(funit_log,'(1X,A56,I5,F5.1,2F11.1)')  &
                   'Point not close enough to any grid cell:',   &
                     t,dp,points(n_nx*n_ny+1)%x, points(n_nx*n_ny+1)%y
                 endif
                aind(t) = 0
             endif

           endif

       enddo

       if (allocated(points) )      deallocate(points )

! ***  PART 2

! *** Now loop through emission input data_array and filter
! *** using the area mask (index aind)
! *** Only the points inside the domain are written to
! *** the filter_array
! *** nareas_new is the new number of domain's area sources

       do n = 1, nareas

          if ( aind(n) == 0 ) then
             xi(n) = 0
             yi(n) = 0
          else

             lenc = 0

! *** Outer loop over x-coordinate seems to be ok.
             do ix = 1,n_nx
                do iy = 1,n_ny
                  lenc = lenc +1
                  if ( lenc == aind(n) ) then
                    xi(n) = ix
                    yi(n) = iy
                  endif
                enddo
             enddo

          endif
          !print *,'xi yi ', n, xi(n), yi(n)

       enddo

! MAYBE THE XI AND YI HAS BE ADDED TO FILTER_ARRAY???

! counter for filter array
       k = 1
       nareas_new = 0
       do n = 1, nareas

          if ( (xi(n).gt.0).and.(yi(n).gt.0) ) then

! *** These line sources will be included
            filter_array(k,:) = data_array(n,:)
            filter_snap(k)    = snap(n)
            filter_xi(k)      = xi(n)
            filter_yi(k)      = yi(n)
            nareas_new = nareas_new + 1
            k = k + 1

          else

! *** These line sources will not be included
            if (fe_log) then
               write(funit_log,'(1X,A78)')  &
                'Area source outside domain - excluded. Input area no., x y(SW), x y(NE)'
               write(funit_log,'(40X,I5,1X,4F11.1)')  &
                 n,data_array(n,1),data_array(n,2),data_array(n,4),data_array(n,5)
            endif
          endif

       enddo

      return

      end subroutine filter_areas