      subroutine updmor ( pmsa   , fl     , ipoint , increm , noseg  , &
     &                    noflux , iexpnt , iknmrk , noq1   , noq2   , &
     &                    noq3   , noq4   )
!DEC$ ATTRIBUTES DLLEXPORT, ALIAS: 'UPDMOR' :: UPDMOR
!>\file
!>       Process: BedUpdate - Update bed levels

!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!------------------------------------------------------------------------------
      use bedcomposition_module, only:updmorlyr
!      use sediment_basics_module
      use message_module, only:writemessages
      use bed_ensemble
      use precision
!
      IMPLICIT NONE
!
!     Type                      Name          I/O Description
!
      real(4), dimension(*)  :: pmsa        !<I/O Process Manager System Array, window of routine to process library
      real(4), dimension(*)  :: fl          !< O  Array of fluxes made by this process in mass/volume/time
      integer, dimension(*)  :: ipoint      !< I  Array of pointers in pmsa to get and store the data
      integer, dimension(*)  :: increm      !< I  Increments in ipoint for segment loop, 0=constant, 1=spatially varying
      integer                :: noseg       !< I  Number of computational elements in the whole model schematisation
      integer                :: noflux      !< I  Number of fluxes, increment in the fl array
      integer, dimension(4,*):: iexpnt      !< I  From, To, From-1 and To+1 segment numbers of the exchange surfaces
      integer, dimension(*)  :: iknmrk      !< I  Active-Inactive, Surface-water-bottom, see manual for use
      integer                :: noq1        !< I  Nr of exchanges in 1st direction (the horizontal dir if irregular mesh)
      integer                :: noq2        !< I  Nr of exchanges in 2nd direction, noq1+noq2 gives hor. dir. reg. grid
      integer                :: noq3        !< I  Nr of exchanges in 3rd direction, vertical direction, pos. downward
      integer                :: noq4        !< I  Nr of exchanges in the bottom (bottom layers, specialist use only)
!
!------------------------------------------------------------------------------
!
!     Type                                  Name          I/O Description                                        Unit
!
      integer                               :: numISS      !< I  number of ISS fractions                            (-)
      integer                               :: numIBS      !< I  number of IBS fractions                            (-)
      real(4)                               :: SBTnrm      !< I  total normal transport comp for IBS frac           (kg/m)
      real(4)                               :: MorFac      !< I  morphological acceleration factor                  (-)
      real(4)                               :: Surf        !< I  horizontal surface area of a DELWAQ segment        (m2)
      real(4)                               :: XWidth      !< I  exchange width                                     (m)
      real(4)                               :: dVB         !< O  segment integrated bed level change                (m3/d)
      real(4)                               :: dZB         !< F  bed level change                                   (m/d)
!
      integer                               :: iflux       !<    Local index for pointering the fluxes
      integer, dimension(:), allocatable    :: ipnt        !<    Local work array for the pointering
      integer                               :: iseg        !<    Local loop counter for computational element loop
      integer                               :: iq          !<    Local loop counter for exchanges loop
      integer                               :: ifrom       !<    Index of from segment
      integer                               :: ito         !<    Index of to segment
      integer                               :: i           !<    Local loop counter for sediment fraction
!
      integer                               :: iSBTnrm     !<    Offset of SBTnrm data in ipnt/increm arrays
      integer                               :: iMorFac     !<    Offset of MorFac data in ipnt/increm arrays
      integer                               :: nItem       !<    Total number of input and output items
!
      integer                               :: pSurf       !<    Offset of Surf data in pmsa array
      integer                               :: numIS       !<    Total number of fractions
      real(fp), dimension(:,:), allocatable :: dbodsd      !<    Bed composition change
      real(fp), dimension(:), allocatable   :: depchg      !<    Bed level change
      real(fp)                              :: S           !<    Total transport flux at exchange
      type(bed_data)                        :: bed         !<    Bed composition data
!
!------------------------------------------------------------------------------
!
      numISS      = int(pmsa( ipoint(  1) ))
      numIBS      = int(pmsa( ipoint(  2) ))
      numIS       = numISS+numIBS
!
      iSBTnrm      = 2
      iMorFac      = iSBTnrm      + numIS
      nItem        = iMorFac      + 4
!
      call failconst(increm(iMorFac+1),'Morphological factor')
      MorFac         = pmsa( ipoint(iMorFac     +  1) )
      allocate( dbodsd(numIS,noseg) )
      dbodsd = 0.0_fp
      allocate( depchg(noseg) )
      depchg = 0.0_fp
!
!     Initialise pointers
!
      allocate(ipnt(nItem))
      ipnt        = ipoint(1:nItem)
!
!     Loop over all exchanges
!
      do iq = 1, noq1+noq2
!
!        Get from and to segments
!
         ifrom = iexpnt(1,iq)
         ito   = iexpnt(2,iq)
!
!        Get input values from arrays
!
         do i = 1, numIS
            SBTnrm = pmsa( ipnt(iSBTnrm+i) )
            XWidth = pmsa( ipnt(iMorFac+3) )
            S = SBTnrm * XWidth * MorFac
            !
            if (ifrom>0) dbodsd(i,ifrom) = dbodsd(i,ifrom) - S
            if (ito>0)   dbodsd(i,ito)   = dbodsd(i,ito)   + S
         enddo
!
!        Increment pointers
!
         ipnt        = ipnt        + increm(1:nItem)
!
      enddo
!
!     Reset pointers
!
      ipnt        = ipoint(1:nItem)
      iflux       = 0
!
!     Convert sediment total mass into sediment per m2
!
      pSurf = ipnt(iMorFac+2)
      do iseg = 1, noseg
         Surf  = pmsa( pSurf )
         do i = 1, numIS
            dbodsd(i,iseg) = dbodsd(i,iseg) / Surf
         enddo
         pSurf = pSurf + increm(iMorFac+2)
      enddo
!
!     Update bedcomposition
!
      call getbedcomp(bed,1,1)
      if (updmorlyr(bed%comp, dbodsd, depchg, bed%messages) /= 0) then
          call writemessages(bed%messages, 6)
          call throwexception()
      endif
!
!     Reset pointers
!
      ipnt        = ipoint(1:nItem)
      iflux       = 0
!
!     Loop over all segments
!
      do iseg = 1, noseg
         Surf  = pmsa( ipnt(iMorFac+2) )
!
         dZB = depchg(iseg)
         dVB = depchg(iseg)*Surf
!
!        Put output and flux values into arrays
!
         fl  ( iflux+1 ) = dZB
         pmsa( ipnt(iMorFac+4) ) = dVB
!
!        Increment pointers
!
         iflux       = iflux       + noflux
         ipnt        = ipnt        + increm(1:nItem)
!
      enddo
!
      deallocate(ipnt)
      deallocate(dbodsd)
      deallocate(depchg)
!
      end subroutine updmor


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2018 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine applympc_dpel(nface,ielfa,xrlfa,vel,vfa,
     &  ifabou,xbounact,nef,gradpcel,gradpcfa,neifa,rf,area,volume,
     &  xle,xxi,icyclic,xxn,ipnei,ifatie,
     &  coefmpc,nmpc,labmpc,ipompc,nodempc,ifaext,nfaext,nactdoh,
     &  iflag,xxj,xlet)
!
!     applying the MPC's in the calculation of the pressure
!     correction
!
      implicit none
!
      character*20 labmpc(*)
!
      integer nface,ielfa(4,*),ifabou(*),i,iel1,iel2,nef,ibou,
     &  neifa(*),icyclic,ifa,indexf,l,m,ipnei(*),ifatie(*),
     &  is,ie,nmpc,ipompc(*),nodempc(3,*),ifaext(*),nfaext,nactdoh(*),
     &  iel,index,mpc,ipointer,k,ielorig,iface,iflag
!
      real*8 xrlfa(3,*),vel(nef,0:7),vfa(0:7,*),xbounact(*),xl1,xl2,
     &   vfap(0:7,nface),gradpcel(3,*),gradpcfa(3,*),rf(3,*),area(*),
     &   volume(*),xle(*),xxi(3,*),c(3,3),gradnor,xxn(3,*),coefmpc(*),
     &   coefnorm,sum,xxj(3,*),xlet(*),dd
!
      intent(in) nface,ielfa,xrlfa,vel,
     &  ifabou,xbounact,nef,neifa,rf,area,volume,
     &  xle,xxi,icyclic,xxn,ipnei,ifatie,
     &  coefmpc,nmpc,labmpc,ipompc,nodempc,ifaext,nfaext,nactdoh
!
      intent(inout) vfa,gradpcel,gradpcfa
!
!     Multiple point constraints
!
      if(nmpc.gt.0) then
         do k=1,nfaext
            i=ifaext(k)
            if(ielfa(2,i).ge.0) cycle
            ipointer=-ielfa(2,i)
            if(ifabou(ipointer+4).ge.0) cycle
            mpc=-ifabou(ipointer+4)
!
            index=ipompc(mpc)
            sum=0.d0
            coefnorm=0.d0
            do
               if(index.eq.0) exit
               if(nodempc(1,index).lt.0) then
!
!                 a negative number refers to a boundary
!                 condition (fields nodeboun, ndirboun..)
!                 resulting from a SPC in local coordinates
!
                  sum=sum+0.d0
               else
!
!                 face term
!
                  ielorig=int(nodempc(1,index)/10.d0)
                  iel=nactdoh(ielorig)
                  iface=nodempc(1,index)-10*ielorig
                  sum=sum+coefmpc(index)
     &                 *vfa(nodempc(2,index),neifa(ipnei(iel)+iface))
                  coefnorm=coefnorm+coefmpc(index)**2
               endif
               index=nodempc(3,index)
            enddo
!
!           distribute the sum across all terms which are not
!           fixed by boundary conditions
!
            index=ipompc(mpc)
            do
               if(index.eq.0) exit
               if(nodempc(1,index).gt.0) then
                  ielorig=int(nodempc(1,index)/10.d0)
                  iel=nactdoh(ielorig)
                  iface=nodempc(1,index)-10*ielorig
                  vfa(nodempc(2,index),neifa(ipnei(iel)+iface))=
     &                 vfa(nodempc(2,index),neifa(ipnei(iel)+iface))-
     &                 sum*coefmpc(index)/coefnorm
               endif
               index=nodempc(3,index)
            enddo
         enddo
      endif
!
      return
      end


module da_par_util

   !---------------------------------------------------------------------------
   ! Purpose: Routines for local-to-global and global-to-local grid operations.
   !
   ! METHOD:  RSL/MPI.
   !---------------------------------------------------------------------------

   use da_control, only: use_rf
   use module_domain, only : domain, xpose_type

#ifdef DM_PARALLEL
   use module_dm, only : local_communicator_x, &
      local_communicator_y, ntasks_x, ntasks_y, data_order_xyz
   use da_par_util1, only : true_mpi_real, true_mpi_complex
!   use mpi, only : mpi_2double_precision, mpi_status_size, &
!     mpi_integer, mpi_maxloc, mpi_status_size, &
!     mpi_minloc, mpi_sum
#else
   use da_reporting, only : message
#endif

   use da_define_structures, only : be_subtype, &
      x_type, vp_type, residual_synop_type, residual_sound_type, iv_type, &
      y_type, count_obs_number_type, maxmin_field_type

   use da_control, only : trace_use,num_ob_indexes, myproc, root, comm, ierr, &
      rootproc, num_procs, stdout, print_detail_parallel, its,ite, jts, jte, &
      kts,kte,ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme,ips,ipe,jps,jpe, &
      kps, kpe, grid_stagger, grid_ordering, trace_use_dull, &
      sound, synop, pilot, satem, geoamv, polaramv, airep, gpspw, gpsref, &
      metar, ships, ssmi_rv, ssmi_tb, ssmt1, ssmt2, qscat, profiler, buoy, bogus, &
      pseudo, radar, radiance, airsr, sonde_sfc, trace_use_frequent, &
      its_int,ite_int,jts_int,jte_int,kts_int,kte_int, &
      ims_int,ime_int,jms_int,jme_int,kms_int,kme_int, &
      ids_int,ide_int,jds_int,jde_int,kds_int,kde_int, &
      ips_int,ipe_int,jps_int,jpe_int,kps_int,kpe_int, &
      anal_type_hybrid_dual_res
   use da_reporting, only : da_error
   use da_tracing, only : da_trace_entry, da_trace_exit
   use da_wrf_interfaces, only : &
      wrf_dm_xpose_z2x, wrf_dm_xpose_x2y, wrf_dm_xpose_y2x, wrf_dm_xpose_x2z, &
      wrf_dm_xpose_z2y, wrf_dm_xpose_y2z, wrf_patch_to_global_real, wrf_debug, &
      wrf_dm_bcast_integer, wrf_dm_bcast_real

   implicit none

#ifdef DM_PARALLEL
   include 'mpif.h'
#endif

#include "da_generic_typedefs.inc"

   interface da_patch_to_global
      module procedure da_patch_to_global_2d
      module procedure da_patch_to_global_3d
   end interface

   contains

#include "da_cv_to_vv.inc"
#include "da_vv_to_cv.inc"
#include "da_alloc_and_copy_be_arrays.inc"
#include "da_copy_dims.inc"
#include "da_copy_tile_dims.inc"
#include "da_pack_count_obs.inc"
#include "da_unpack_count_obs.inc"
#include "da_transpose_x2y.inc"
#include "da_transpose_y2x.inc"
#include "da_transpose_z2x.inc"
#include "da_transpose_x2z.inc"
#include "da_transpose_y2z.inc"
#include "da_transpose_z2y.inc"
#include "da_transpose_x2y_v2.inc"
#include "da_transpose_y2x_v2.inc"

#include "da_cv_to_global.inc"
#include "da_patch_to_global_2d.inc"
#include "da_patch_to_global_3d.inc"
#include "da_generic_methods.inc"
#include "da_deallocate_global_sonde_sfc.inc"
#include "da_deallocate_global_sound.inc"
#include "da_deallocate_global_synop.inc"
#include "da_generic_boilerplate.inc"
#include "da_y_facade_to_global.inc"
#include "da_system.inc"

#include "da_patch_to_global_dual_res.inc"

#ifdef DM_PARALLEL
#include "da_proc_stats_combine.inc"
#include "da_proc_maxmin_combine.inc"
#else
#include "da_wrf_dm_interface.inc"
#endif

end module da_par_util


MODULE m_bmt
contains
  SUBROUTINE bmt(&
       & stars,input,noco,atoms,sphhar,vacuum,&
       & cell,sym,oneD)

    USE m_constants
    USE m_types
    USE m_juDFT
    USE m_cdn_io
    USE m_wrtdop
    IMPLICIT NONE
    !     ..
    TYPE(t_stars),INTENT(IN)    :: stars
    TYPE(t_input),INTENT(IN)    :: input
    TYPE(t_noco),INTENT(IN)     :: noco
    TYPE(t_atoms),INTENT(IN)    :: atoms
    TYPE(t_sphhar),INTENT(IN)   :: sphhar
    TYPE(t_vacuum),INTENT(IN)   :: vacuum
    TYPE(t_cell),INTENT(IN)     :: cell
    TYPE(t_sym),INTENT(IN)      :: sym
    TYPE(t_oneD),INTENT(IN)     :: oneD

    TYPE(t_potden) :: den

    INTEGER k,i,ivac
    INTEGER type,typmag, archiveType
    REAL fermiEnergyTemp
    LOGICAL l_qfix
    CHARACTER(len=8) filename

    typmag= atoms%ntype
    ! only muffin-tins with type <= typmag remain magnetic

    IF (input%jspins/=2) THEN
       CALL juDFT_error("Stop in bmt:  jspins/=2",calledby="bmt")
    ENDIF

    !atoms%jmtd = maxval(atoms%jri(:))
    !sphhar%nlhd = maxval(sphhar%nlh(:))

    CALL den%init(stars,atoms,sphhar,vacuum,noco,input%jspins,POTDEN_TYPE_DEN)
    IF(noco%l_mtNocoPot) THEN
       archiveType=CDN_ARCHIVE_TYPE_FFN_const
    ELSE IF(noco%l_noco) THEN
       archiveType = CDN_ARCHIVE_TYPE_NOCO_const
    ELSE
       archiveType = CDN_ARCHIVE_TYPE_CDN1_const
    END IF

    CALL readDensity(stars,noco,vacuum,atoms,cell,sphhar,input,sym,oneD,archiveType,&
                     CDN_INPUT_DEN_const,0,fermiEnergyTemp,l_qfix,den)

    IF ( typmag < atoms%ntype ) THEN
       DO type= typmag+1,atoms%ntype
          DO k= 0,sphhar%nlhd
             DO i= 1,atoms%jmtd
                den%mt(i,k,type,1)= (den%mt(i,k,type,1) + den%mt(i,k,type,2))/2.
                den%mt(i,k,type,2)= den%mt(i,k,type,1)
             ENDDO
          ENDDO
       ENDDO
    ENDIF

    DO k= 1,stars%ng3
       den%pw(k,1)= (den%pw(k,1) + den%pw(k,2))/2.0
       den%pw(k,2)= den%pw(k,1)
    ENDDO
    IF (input%film) THEN
       DO ivac= 1,vacuum%nvac
          DO i= 1,vacuum%nmz
             den%vacz(i,ivac,1)= (den%vacz(i,ivac,1) + den%vacz(i,ivac,2))/2.0
             den%vacz(i,ivac,2)= den%vacz(i,ivac,1)
          ENDDO
          DO k= 2,stars%ng2
             DO i= 1,vacuum%nmzxy
                den%vacxy(i,k-1,ivac,1)= (den%vacxy(i,k-1,ivac,1) + den%vacxy(i,k-1,ivac,2))/2.0
                den%vacxy(i,k-1,ivac,2)= den%vacxy(i,k-1,ivac,1)
             ENDDO
          ENDDO
       ENDDO
    ENDIF

    filename= 'cdnbmtXX'
    IF ( typmag < atoms%ntype ) THEN
       filename(7:7)= ACHAR(IACHAR('0')+ MOD(typmag,100)/10 )
       filename(8:8)= ACHAR(IACHAR('0')+ MOD(typmag,10) )
       OPEN(98,file=filename(1:8),form='unformatted',status='replace')
    ELSE
       OPEN(98,file=filename(1:6),form='unformatted',status='replace')
    ENDIF
    CALL wrtdop(&
         & stars,vacuum,atoms,sphhar,input,sym,&
         & 98,&
         & den%iter,den%mt,den%pw,den%vacz,den%vacxy)
    CLOSE(98)

  END SUBROUTINE bmt
END MODULE m_bmt


C
C       $Id: vvdrfl.f,v 1.11 2008-07-27 00:17:35 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE VVDRFL (XB,YB,XE,YE,VLN,LBL,NC,IAM,VVUDMV,IDA)
C
      DIMENSION IAM(*)
C
      EXTERNAL VVUDMV
C
C This routine is called to draw a single filled arrow. Its
C arguments are the same as the line-based arrow drawing routine
C VVDRAW. However it recognizes some parameters that the line arrow
C routine does not. It has arguments as follows -
C
C XB,YB    -  Coordinate of arrow base, fractional coordinate
C XE,YE    -  Coordinate of arrow head, fractional coordinate
C VLN      -  Length of the vector (arrow)
C          -  (if negative does not draw the vector, but just
C          -  calculates the vector's height and width)
C LBL      -  Character label to be put above arrow.
C NC       -  Number of characters in label.
C IAM      -  Area map (optional) for masking vectors
C VVUDMV   -  User-supplied function for drawing masked vectors
C IDA      -  Do area masking flag
C
C ---------------------------------------------------------------------
C
C NOTE:
C Since implicit typing is used for all real and integer variables
C a consistent length convention has been adopted to help clarify the
C significance of the variables encountered in the code for this
C utility. All local variable and subroutine parameter identifiers
C are limited to 1,2,or 3 characters. Four character names identify
C members of common blocks. Five and 6 character variable names
C denote PARAMETER constants or subroutine or function names.
C
C Declare the VV common blocks.
C
C IPLVLS - Maximum number of color threshold level values
C IPAGMX - Maximum number of area groups allowed in the area map
C
      PARAMETER (IPLVLS = 256, IPAGMX = 64)
C
C Integer and real common block variables
C
C
      COMMON /VVCOM/
     +                IUD1       ,IVD1       ,IPD1       ,IXDM       ,
     +                IYDN       ,VLOM       ,VHIM       ,ISET       ,
     +                VRMG       ,VRLN       ,VFRC       ,IXIN       ,
     +                IYIN       ,ISVF       ,UUSV       ,UVSV       ,
     +                UPSV       ,IMSK       ,ICPM       ,UVPS       ,
     +                UVPL       ,UVPR       ,UVPB       ,UVPT       ,
     +                UWDL       ,UWDR       ,UWDB       ,UWDT       ,
     +                UXC1       ,UXCM       ,UYC1       ,UYCN       ,
     +                NLVL       ,IPAI       ,ICTV       ,WDLV       ,
     +                UVMN       ,UVMX       ,PMIN       ,PMAX       ,
     +                RVMN       ,RVMX       ,RDMN       ,RDMX       ,
     +                ISPC       ,RVMD       ,IPLR       ,IVST       ,
     +                IVPO       ,ILBL       ,IDPF       ,IMSG       ,
     +                ICLR(IPLVLS)           ,TVLU(IPLVLS)
C
C Arrow size/shape parameters
C
        COMMON / VVARO /
     +                HDSZ       ,HINF       ,HANG       ,IAST       ,
     +                HSIN       ,HCOS       ,FAMN       ,FAMX       ,
     +                UVMG       ,FAIR       ,FAWR       ,FAWF       ,
     +                FAXR       ,FAXF       ,FAYR       ,FAYF       ,
     +                AROX(8)    ,AROY(8)    ,FXSZ       ,FYSZ       ,
     +                FXRF       ,FXMN       ,FYRF       ,FYMN       ,
     +                FWRF       ,FWMN       ,FIRF       ,FIMN       ,
     +                AXMN       ,AXMX       ,AYMN       ,AYMX       ,
     +                IACM       ,IAFO       ,WBAD       ,WBTF       ,
     +                WBCF       ,WBDF       ,WBSC
C
C
C Text related parameters
C
        COMMON /VVTXP /
     +                FCWM    ,ICSZ    ,
     +                FMNS    ,FMNX    ,FMNY    ,IMNP    ,IMNC  ,
     +                FMXS    ,FMXX    ,FMXY    ,IMXP    ,IMXC  ,
     +                FZFS    ,FZFX    ,FZFY    ,IZFP    ,IZFC  ,
     +                FILS    ,FILX    ,FILY    ,IILP    ,IILC  ,
     +                FLBS    ,ILBC

C
C Character variable declartions
C
      CHARACTER*160 CSTR
      PARAMETER (IPCHSZ=36)
      CHARACTER*(IPCHSZ)  CMNT,CMXT,CZFT,CLBT,CILT
C
C Text string parameters
C
      COMMON /VVCHAR/ CSTR,CMNT,CMXT,CZFT,CLBT,CILT
C
      SAVE /VVCOM/, /VVARO/, /VVTXP/, /VVCHAR/
C
C The mapping common block: made available to user mapping routines
C
      COMMON /VVMAP/
     +                IMAP       ,
     +                XVPL       ,XVPR       ,YVPB       ,YVPT       ,
     +                WXMN       ,WXMX       ,WYMN       ,WYMX       ,
     +                XLOV       ,XHIV       ,YLOV       ,YHIV       ,
     +                SXDC       ,SYDC       ,NXCT       ,NYCT       ,
     +                RLEN       ,LNLG       ,INVX       ,INVY       ,
     +                ITRT       ,IWCT       ,FW2W       ,FH2H       ,
     +                DVMN       ,DVMX       ,RBIG       ,IBIG
C
      SAVE /VVMAP/
C
C Math constants
C
      PARAMETER (PDTOR  = 0.017453292519943,
     +           PRTOD  = 57.2957795130823,
     +           P1XPI  = 3.14159265358979,
     +           P2XPI  = 6.28318530717959,
     +           P1D2PI = 1.57079632679489,
     +           P5D2PI = 7.85398163397448)
C
C --------------------------------------------------------------------
C
C Local parameters
C
C Number of points in an arrow
C
      PARAMETER (IPAPCT=8)
C
C Local arrays
C
      DIMENSION IAI(IPAGMX),IAG(IPAGMX)
      DIMENSION XO(IPAPCT),YO(IPAPCT)
C
      PARAMETER (IADIM=8,D2RAD=.017453293)
      DIMENSION ARROWX(IADIM),ARROWY(IADIM),AOUTX(IADIM),AOUTY(IADIM)
      DIMENSION WIN(4),VPT(4)
C
      CHARACTER*10 LBL
C
      IF (VLN.LT.0.0) THEN
         ISZ=1
         VLL=-VLN
      ELSE
         ISZ=0
         VLL=VLN
      END IF
C
C Transfer arguments to local variables and compute the vector length.
C
      DX=XE-XB
      DY=YE-YB
C
C Adjust the coordinates of the vector endpoints as implied by the
C vector positioning option.
C
      IF (IVPO .LT. 0) THEN
         AXE = XB
         AYE = YB
         AXB = XB - DX
         AYB = YB - DY
      ELSE IF (IVPO .EQ. 0) THEN
         AXB = XB - 0.5*DX
         AYB = YB - 0.5*DY
         AXE = XE - 0.5*DX
         AYE = YE - 0.5*DY
      ELSE
         AXB = XB
         AYB = YB
         AXE = XE
         AYE = YE
      END IF
C
      IF (FAWF .LE. 0.0 .AND. FAYF .LE. 0.0 .AND. FAXF .LE. 0.0) THEN
         DO 10 I=1,IADIM
            ARROWX(I) = VLL * AROX(I)
            ARROWY(I) = VLL * AROY(I)
 10      CONTINUE
      ELSE
         RFM = UVMX
         IF (VRMG.GT.0.0) RFM = VRMG
         VRL = DVMX
         IF (VRLN.GT.0.0) VRL = VRLN*FW2W
         FMG = UVMG/RFM
         IF (FAWF.GT.0) THEN
            WSZ = FWMN + MAX(0.0,FWRF-FWMN)*FMG
         ELSE
            WSZ = VLL*FAWR*0.5
         END IF
         IF (FAXF.GT.0) THEN
            XSZ = FXMN + MAX(0.0,FXRF-FXMN)*FMG
            ESZ = MIN(VLL,FIMN + MAX(0.0,FIRF-FIMN)*FMG)
         ELSE
            XSZ = VLL*FAXR
            ESZ = VLL*FAIR
         END IF
         IF (FAYF.GT.0) THEN
            YSZ = WSZ+FYMN+MAX(0.0,FYRF-FYMN)*FMG
         ELSE
            YSZ = WSZ+VLL*FAYR
         END IF
C
         ARROWX(1) = VLL*AROX(1)
         ARROWX(3) = -XSZ
         ARROWX(4) = 0.0
         ARROWX(5) = -XSZ
         ARROWX(7) = VLL*AROX(7)
         ARROWX(8) = VLL*AROX(8)
         ARROWY(1) = -WSZ
         ARROWY(2) = -WSZ
         ARROWY(3) = -YSZ
         ARROWY(4) = 0.0
         ARROWY(5) = YSZ
         ARROWY(6) = WSZ
         ARROWY(7) = WSZ
         ARROWY(8) = -WSZ
C
         IF (WSZ.GT.0.0) THEN
C
C Find point of intersection of line between rear arrowhead tip and
C the X interior point and the line forming the edge of the arrow body
C using ratio of similar triangles
C
            ARROWX(2) = -(ESZ + ABS(XSZ-ESZ)*WSZ/(WSZ+YSZ))
         ELSE
            ARROWX(2) = -ESZ
         END IF
         ARROWX(6) = ARROWX(2)
C
      END IF
      IF (FAXR .LE. 0.4) THEN
         RMG = ARROWY(6)
      ELSE
         RMG = MAX(ARROWY(5),ARROWY(6))
      END IF
C
C  Rotate and translate the arrow.
C
      COSANG = DX / VLL
      SINANG = DY / VLL
      DO 20 I=1,IADIM
         AOUTX(I) = AXE+ARROWX(I)*COSANG-ARROWY(I)*SINANG
         AOUTY(I) = AYE+ARROWX(I)*SINANG+ARROWY(I)*COSANG
 20   CONTINUE
C
C Early return if just calculating the size
C
      IF (ISZ.EQ.1) THEN
C
         AYMN = 100.0
         AYMX = -100.
         AXMN = 100.0
         AXMX = -100.0
         DO 50 I=1,IADIM
            IF (AOUTX(I) .LT. AXMN) AXMN = AOUTX(I)
            IF (AOUTX(I) .GT. AXMX) AXMX = AOUTX(I)
            IF (AOUTY(I) .LT. AYMN) AYMN = AOUTY(I)
            IF (AOUTY(I) .GT. AYMX) AYMX = AOUTY(I)
 50      CONTINUE
         FXSZ = AXMX-AXMN
         FYSZ = AYMX-AYMN
C
         RETURN
      END IF
C
C Set the the normalization transformation to an identity. Can't use
C the default transformation because we need to clip to the viewport
C
      CALL GQCNTN(IER,NTR)
      CALL GQNT(NTR,IER,WIN,VPT)
      CALL GSWN(NTR,VPT(1),VPT(2),VPT(3),VPT(4))
C
C Output the arrow, using the masking routines if specified.
C
      IF (IDA .GT. 1) THEN
         CALL ARGTAI(IAM,XB,YB,IAI,IAG,IPAGMX,NAI,0)
         CALL VVUDMV(AOUTX,AOUTY,IPAPCT,IAI,IAG,NAI)
      ELSE IF (IDA .EQ. 1) THEN
         CALL ARDRLN(IAM,AOUTX,AOUTY,IPAPCT,
     +        XO,YO,IPAPCT,IAI,IAG,IPAGMX,VVUDMV)
      ELSE
         IF (IAFO.GT.0 .AND. IACM.GT.-2) THEN
            CALL GPL(IPAPCT,AOUTX,AOUTY)
         END IF
         IF (IACM.NE.-1) THEN
            CALL GFA(IPAPCT,AOUTX,AOUTY)
         END IF
         IF (IAFO.LE.0 .AND. IACM.GT.-2) THEN
            CALL GPL(IPAPCT,AOUTX,AOUTY)
         END IF
      END IF
C
C If requested, put the vector magnitude above the arrow.
C
      IF (NC .GT. 0) THEN
C
         PHI = ATAN2(DY,DX)
         IF (MOD(PHI+P5D2PI,P2XPI) .GT. P1XPI) PHI = PHI+P1XPI
         XC = AXB+0.33*(AXE-AXB) +
     +        (1.25*FLBS*FW2W+RMG)*COS(PHI+P1D2PI)
         YC = AYB+0.33*(AYE-AYB) +
     +        (1.25*FLBS*FW2W+RMG)*SIN(PHI+P1D2PI)
C
         CALL PLCHLQ(XC,YC,LBL(1:NC),FLBS*FW2W,PRTOD*PHI,0.0)
C
      END IF
C
C Restore the original transformation
C
      CALL GSWN(NTR,WIN(1),WIN(2),WIN(3),WIN(4))
C
      RETURN
      END
C
      SUBROUTINE VVINFA ()
C
C Initializes filled arrow common block values
C
C ---------------------------------------------------------------------
C
C NOTE:
C Since implicit typing is used for all real and integer variables
C a consistent length convention has been adopted to help clarify the
C significance of the variables encountered in the code for this
C utility. All local variable and subroutine parameter identifiers
C are limited to 1,2,or 3 characters. Four character names identify
C members of common blocks. Five and 6 character variable names
C denote PARAMETER constants or subroutine or function names.
C
C Declare the VV common blocks.
C
C IPLVLS - Maximum number of color threshold level values
C IPAGMX - Maximum number of area groups allowed in the area map
C
      PARAMETER (IPLVLS = 256, IPAGMX = 64)
C
C Integer and real common block variables
C
C
      COMMON /VVCOM/
     +                IUD1       ,IVD1       ,IPD1       ,IXDM       ,
     +                IYDN       ,VLOM       ,VHIM       ,ISET       ,
     +                VRMG       ,VRLN       ,VFRC       ,IXIN       ,
     +                IYIN       ,ISVF       ,UUSV       ,UVSV       ,
     +                UPSV       ,IMSK       ,ICPM       ,UVPS       ,
     +                UVPL       ,UVPR       ,UVPB       ,UVPT       ,
     +                UWDL       ,UWDR       ,UWDB       ,UWDT       ,
     +                UXC1       ,UXCM       ,UYC1       ,UYCN       ,
     +                NLVL       ,IPAI       ,ICTV       ,WDLV       ,
     +                UVMN       ,UVMX       ,PMIN       ,PMAX       ,
     +                RVMN       ,RVMX       ,RDMN       ,RDMX       ,
     +                ISPC       ,RVMD       ,IPLR       ,IVST       ,
     +                IVPO       ,ILBL       ,IDPF       ,IMSG       ,
     +                ICLR(IPLVLS)           ,TVLU(IPLVLS)
C
C Arrow size/shape parameters
C
        COMMON / VVARO /
     +                HDSZ       ,HINF       ,HANG       ,IAST       ,
     +                HSIN       ,HCOS       ,FAMN       ,FAMX       ,
     +                UVMG       ,FAIR       ,FAWR       ,FAWF       ,
     +                FAXR       ,FAXF       ,FAYR       ,FAYF       ,
     +                AROX(8)    ,AROY(8)    ,FXSZ       ,FYSZ       ,
     +                FXRF       ,FXMN       ,FYRF       ,FYMN       ,
     +                FWRF       ,FWMN       ,FIRF       ,FIMN       ,
     +                AXMN       ,AXMX       ,AYMN       ,AYMX       ,
     +                IACM       ,IAFO       ,WBAD       ,WBTF       ,
     +                WBCF       ,WBDF       ,WBSC
C
C
C Text related parameters
C
        COMMON /VVTXP /
     +                FCWM    ,ICSZ    ,
     +                FMNS    ,FMNX    ,FMNY    ,IMNP    ,IMNC  ,
     +                FMXS    ,FMXX    ,FMXY    ,IMXP    ,IMXC  ,
     +                FZFS    ,FZFX    ,FZFY    ,IZFP    ,IZFC  ,
     +                FILS    ,FILX    ,FILY    ,IILP    ,IILC  ,
     +                FLBS    ,ILBC

C
C Character variable declartions
C
      CHARACTER*160 CSTR
      PARAMETER (IPCHSZ=36)
      CHARACTER*(IPCHSZ)  CMNT,CMXT,CZFT,CLBT,CILT
C
C Text string parameters
C
      COMMON /VVCHAR/ CSTR,CMNT,CMXT,CZFT,CLBT,CILT
C
      SAVE /VVCOM/, /VVARO/, /VVTXP/, /VVCHAR/
C
C The mapping common block: made available to user mapping routines
C
      COMMON /VVMAP/
     +                IMAP       ,
     +                XVPL       ,XVPR       ,YVPB       ,YVPT       ,
     +                WXMN       ,WXMX       ,WYMN       ,WYMX       ,
     +                XLOV       ,XHIV       ,YLOV       ,YHIV       ,
     +                SXDC       ,SYDC       ,NXCT       ,NYCT       ,
     +                RLEN       ,LNLG       ,INVX       ,INVY       ,
     +                ITRT       ,IWCT       ,FW2W       ,FH2H       ,
     +                DVMN       ,DVMX       ,RBIG       ,IBIG
C
      SAVE /VVMAP/
C
C Math constants
C
      PARAMETER (PDTOR  = 0.017453292519943,
     +           PRTOD  = 57.2957795130823,
     +           P1XPI  = 3.14159265358979,
     +           P2XPI  = 6.28318530717959,
     +           P1D2PI = 1.57079632679489,
     +           P5D2PI = 7.85398163397448)
C
C --------------------------------------------------------------------
C
C
C Fill in the reference arrow data
C
      WID = 0.5 * FAWR
      AROX(1) = -1.0
      AROX(2) = -FAIR
      AROX(3) = -FAXR
      AROX(4) = 0.0
      AROX(5) = -FAXR
      AROX(6) = -FAIR
      AROX(7) = -1.0
      AROX(8) = -1.0
      AROY(1) = -WID
      AROY(2) = -WID
      AROY(3) = -WID-FAYR
      AROY(4) = 0.0
      AROY(5) = WID+FAYR
      AROY(6) = WID
      AROY(7) = WID
      AROY(8) = -WID
C
      IF (WID.GT.0.0) THEN
C
C Find point of intersection of line between rear arrowhead tip and
C the X interior point and the line forming the edge of the arrow body
C using ratio of similar triangles
C
         AROX(2) = - (FAIR + ABS(FAXR-FAIR)*WID/(WID+FAYR))
      ELSE
         AROX(2) = -FAIR
      END IF
      AROX(6) = AROX(2)
C
      VRL = DVMX
      IF (VRLN.GT.0.0) VRL = VRLN*FW2W
      FWRF = VRL*WID
      FWMN = FWRF*FAWF
      FXRF = VRL*FAXR
      FXMN = FXRF*FAXF
      FIRF = VRL*FAIR
      FIMN = FIRF*FAXF
      FYRF = VRL*FAYR
      FYMN = FYRF*FAYF
C
      RETURN
      END


      SUBROUTINE PK_SECT7(KFILDO,IA,NXY,IPACK,ND5,LOCN,IPOS,
     1                    IS5,NS5,IS6,NS6,IS7,NS7,INC,MINPK,MISSP,MISSS,
     2                    IPKOPT,LOCN5_20,IPOS5_20,LOCN5_32,
     3                    IPOS5_32,L3264B,IER,ISEVERE,*)
C
C        MARCH    2000   GLAHN   TDL   FOR GRIB2
C        JANUARY  2001   GLAHN   COMMENTS; ADDED CHECK ON SIZE OF
C                                IS5( ) AND ON IS6(5) = 6; REMOVED
C                                IS7(5) = 7; ADDED IER = 703 FOR
C                                A TYPE OF PACKING ERROR
C        NOVEMBER 2001   GLAHN   A FEW DIAGNOSTIC FORMAT CHANGES;
C                                SPLIT TEST ON NS7 AND IS7(5)
C        JANUARY  2002   GLAHN   SET SECTION NUMBER = 99 IN PACKED
C                                DATA WHEN SEVERE ERROR OCCURS
C        FEBRUARY 2002   GLAHN   ADDED SECTIONS 6,7 PRINT FOR SIMPLE
C        MARCH    2002   GALHN   ADDED NON FATAL ERROR RETURNS VIA
C                                IERSAV; ADDED IER=0
C
C        PURPOSE
C            PACKS DATA SECTION 7, THE DATA SECTION, OF A GRIB2
C            MESSAGE.
C
C        DATA SET USE
C           KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT)
C
C        VARIABLES
C              KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT)
C               IA(J) = THE DATA TO PACK (J=1,NXY).  (INPUT)
C                 NXY = THE SIZE OF IA( ).  (INPUT)
C            IPACK(J) = THE ARRAY THAT HOLDS THE ACTUAL PACKED MESSAGE
C                       (J=1,ND5). (INPUT/OUTPUT)
C                 ND5 = THE SIZE OF THE ARRAY IPACK( ). (INPUT)
C                LOCN = THE WORD POSITION TO PLACE THE NEXT VALUE.
C                       (INPUT/OUTPUT)
C                IPOS = THE BIT POSITION IN LOCN TO START PLACING
C                       THE NEXT VALUE. (INPUT/OUTPUT)
C              IS5(J) = CONTAINS THE GRID DEFINITION DATA THAT
C                       WILL BE PACKED INTO IPACK( ) (J=1,NS5).
C                       (INPUT/OUTPUT)
C                 NS5 = SIZE OF IS5( ). (INPUT)
C              IS6(J) = CONTAINS THE BIT MAP INFORMATION
C                       CORRESPONDING TO SECTION 6 OF GRIB2 (J=1,NS6).
C                       (INPUT)
C                 NS6 = SIZE OF IS6( ). (INPUT)
C              IS7(J) = CONTAINS THE GRID DEFINITION DATA THAT
C                       WILL BE PACKED INTO IPACK( ) (J=1,NS7).
C                       (INPUT/OUTPUT)
C                 NS7 = SIZE OF IS7( ). (INPUT)
C                 INC = THE INCREMENT TO USE IN DEFINING GROUPS.
C                       (INPUT)
C               MINPK = THE MINIMUM GROUP SIZE.  (INPUT)
C               MISSP = THE PRIMARY MISSING VALUE.  (INPUT)
C               MISSS = THE SECONDARY MISSING VALUE.  (INPUT)
C              IPKOPT = PACKING INDICATOR:
C                       0 = ERROR, DON'T PACK
C                       1 = PACK IA( ), SIMPLE
C                       2 = PACK IA( ) AND IB( ), SIMPLE
C                       3 = PACK COMPLEX OR SPATIAL DIFFERENCING
C                       4 = PACK COMPLEX.
C                      (INPUT)
C           LOCN5_20 = LOCN FOR OCTET 20 IN SECTION 5.  (INPUT)
C           IPOS5_20 = IPOS FOR OCTET 20 IN SECTION 5.  (INPUT)
C           LOCN5_32 = LOCN FOR OCTET 32 IN SECTION 5.  (INPUT)
C           IPOS5_32 = IPOS FOR OCTET 32 IN SECTION 5.  (INPUT)
C              L3264B = THE INTEGER WORD LENGTH IN BITS OF THE MACHINE
C                       BEING USED. VALUES OF 32 AND 64 ARE
C                       ACCOMMODATED. (INPUT)
C                 IER = RETURN STATUS CODE. (OUTPUT)
C                          0 = GOOD RETURN.
C                          1 = PACKING WOULD OVERFLOW IPACK( ).
C                          2 = IPOS NOT IN RANGE 1 TO L3264B.
C                          3 = NBIT NOT IN RANGE 0 TO 32.
C                          4 = NBIT EQ 0, BUT NVALUE NE 0.
C                        701 = IS7(5) DOES NOT INDICATE SECTION 7.
C                        702 = IS7( ) HAS NOT BEEN DIMENSIONED LARGE ENOUGH
C                              TO CONTINUE SECTION 7.
C                        703 = NOT SUPPORTED TYPE OF PACKING.
C                        711 = LBIT INCORRECT.  RETURNED FROM PK_CMPLX.
C                        712 = INCORRECT SPLITTING METHOD.  RETURNED
C                              FROM PK_CMPLX.
C                        713 = UNRECOGNIZED MISSING VALUE FLAG
C                              IN IS5(23).  RETURNED FROM PK_CMPLX.
C             ISEVERE = THE SEVERITY LEVEL OF THE ERROR.
C                       1 = NON FATAL ERROR
C                       2 = A FATAL ERROR
C                       (OUTPUT)
C                   * = ALTERNATE RETURN WHEN IER NE 0.
C
C             LOCAL VARIABLES
C               CFEED = CONTAINS THE CHARACTER REPRESENTATION
C                       OF A PRINTER FORM FEED.
C               IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER
C                       FORM FEED.
C               IZERO = CONTAINS THE VALUE '0'.  THIS IS USED IN THE
C                       CODE SIMPLY TO EMPHASIZE THAT A CERTAIN
C                       GROUP OF OCTETS IN THE MESSAGE ARE BEING
C                       ZEROED OUT.
C                   N = L3264B = THE INTEGER WORD LENGTH IN BITS OF
C                       THE MACHINE BEING USED. VALUES OF 32 AND
C                       64 ARE ACCOMMODATED.
C                IBIT = THE NUMBER OF BITS TO USE TO PACK EACH VALUE
C                       FOR SIMPLE PACKING.  FOR COMPLEX PACKING, IBIT
C                       IS THE BITS TO USE TO PACK THE GROUP MINIMA.
C                       IS5(20) SET TO IBIT.
C               IFILL = NUMBER OF BITS NECESSARY TO FILL OUT AN OCTET.
C         LOCN7,IPOS7 = WORD AND BIT POSITION OF BEGINNNING OF
C                       SECTION 7.
C        1         2         3         4         5         6         7 X
C
C        NON SYSTEM SUBROUTINES CALLED
C           PKBG, PK_SMPLE, PK_CMPLX, LENGTH
C
      CHARACTER*1 CFEED
C
      DIMENSION IA(ND5),IPACK(ND5),IS5(NS5),IS6(NS6),IS7(NS7)
C
      DATA IFEED/12/
      DATA IZERO/0/
C
      IER=0
      IERSAV=0
      N=L3264B
      CFEED=CHAR(IFEED)
C
      LOCN7=LOCN
      IPOS7=IPOS
C
C        ALL ERRORS GENERATED BY THIS ROUTINE WHERE THE ALTERNATE
C        RETURN IS USED ARE FATAL.  NON FATAL ERRORS USE THE
C        NORMAL RETURN.
      ISEVERE=2
C        IERSAV CAN SAVE AN ERROR RETURN FROM ANOTHER SUBROUTINE.
C
C        CHECK TO MAKE SURE THAT DATA HAS BEEN PROVIDED FOR
C        SECTION 7.
C
      IF(NS7.LT.5)THEN
         IER=702
         GO TO 900
      ELSE
C
         IF(IS7(5).NE.7)THEN
            IER=701
            GO TO 900
         ENDIF
C
C           BYTES 1-4 MUST BE FILLED IN LATER WITH THE RECORD LENGTH
C           IN BYTES; ABOVE STATEMENT HOLDS THE PLACE.  LOCN7 AND
C           IPOS7 HOLD THE LOCATION.
C
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,32,N,IER,*900)
C
         LOCNS=LOCN
         IPOSS=IPOS
C           SAVE LOCN AND IPOS IN CASE OF ERROR, SECTION NUMBER IS
C           SET TO 99.
         CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IS7(5),8,N,IER,*900)
C
C           DETERMINE THE PACKING METHOD THAT WE WILL
C           USE.
C
         IF(IPKOPT.EQ.1.OR.IPKOPT.EQ.2)THEN
C
C              THIS IS THE SIMPLE METHOD.  THERE ARE IS5(6) VALUES
C              TO PACK.
C
            CALL PK_SMPLE(KFILDO,IA,IS5(6),IPACK,ND5,LOCN,IPOS,IBIT,
     1                       N,IER,*900)
         ELSEIF(IPKOPT.EQ.3.OR.IPKOPT.EQ.4)THEN
C
C              THIS IS THE COMPLEX METHOD OR SPATIAL DIFFERENCE.
C
            CALL PK_CMPLX(KFILDO,IA,NXY,IPACK,ND5,LOCN,IPOS,
     1                    IS5,NS5,IS7,NS7,INC,MINPK,MISSP,
     2                    MISSS,IBIT,LOCN5_32,IPOS5_32,N,
     3                    IER,*900)
            IERSAV=IER
            IER=0
C              IERSAV CAN BE USED TO PROVIDE ERROR TRACING.
C              SUBROUTINE REDUCE CAN PRODUCE NON FATAL ERRORS.
C              OTHER ERRORS ARE FATAL AND RETURN IS TO *900.

         ELSE
            IER=703
C              NOT RECOGNIZED TYPE OF PACKING.
            GO TO 900
         ENDIF
C
C              FILL IS5(20) WITH IBIT.  THIS CAN COME FROM
C              EITHER PK_SMPLE OR PK_CMPLX.
C
         IS5(20)=IBIT
         CALL PKBG(KFILDO,IPACK,ND5,LOCN5_20,IPOS5_20,IBIT,8,N,IER,
     1             *900)
C
C           PAD WITH ZEROS TO FILL OUT AN OCTET, IF NECESSARY.
C
         IFILL=MOD(33-IPOS,8)
C
         IF(IFILL.NE.0)THEN
            CALL PKBG(KFILDO,IPACK,ND5,LOCN,IPOS,IZERO,IFILL,N,IER,
     1                *900)
         ENDIF
C
         IS7(1)=LENGTH(KFILDO,IPACK,ND5,N,LOCN7,IPOS7,LOCN,
     1                 IPOS,IER)
C
C           WRITE OUT THE CONTENTS OF SECTION 5 AND THE NON-DATA
C           CONTENTS OF SECTION 7.  SEPARATE SIMPLE, COMPLEX AND
C           COMPLEX WITH SECOND ORDER DIFFERENCES
C
         IF(IS5(10).EQ.0)THEN
D           WRITE(KFILDO,5)
D5          FORMAT(/' *******************************************'
C***D           WRITE(KFILDO,5)CFEED
C***D5          FORMAT(A1,/' *******************************************'
D    1                /' DATA VALUES FOR SECTIONS 5, 6 - SIMPLE PACKING'
D    2                /' *******************************************')
D           WRITE(KFILDO,6)IS5(1),IS5(5),IS5(6),IS5(10),IS5(12),IS5(16),
D    1                     IS5(18),IS5(20),IS5(21),IS6(6),IS6(1)
D6          FORMAT(/' 1:LENGTH OF SECTION ',T56,I10,
D    1      /' 5:NUMBER OF SECTION',T60,I6,
D    2      /' 6:NUMBER OF ACTUAL DATA POINTS ',T56,I10,
D    3      /' 10:DATA REPRESENTATION TEMPLATE NUMBER ',T60,I6,
D    4      /' 12:REFERENCE VALUE ',T54,I12,
D    5      /' 16:BINARY SCALE FACTOR ',T60,I6,
D    6      /' 18:DECIMAL SCALE FACTOR ',T60,I6,
D    7      /' 20:BITS FOR EACH PACKED VALUE',T60,I6,
D    8      /' 21:TYPE OF VALUES ',T60,I6,
D    9      /'  6:BITMAP INDICATOR (SECTON 6) ',T60,I6,
D    A      /'  1:LENGTH OF SECTION 6 ',T56,I10)
C
D        ELSEIF(IS5(10).EQ.2)THEN
D           WRITE(KFILDO,10)
D10         FORMAT(/' *******************************************'
C***D           WRITE(KFILDO,10)CFEED
C***D10         FORMAT(A1,/' *******************************************'
D    1                /' DATA VALUES FOR SECTION 5 - COMPLEX PACKING'
D    3                /' *******************************************')
D           WRITE(KFILDO,20)IS5(1),IS5(5),IS5(6),IS5(10),IS5(12),
D    1                      IS5(16),IS5(18),IS5(20),IS5(21),IS5(22),
D    2                      IS5(23),IS5(24),IS5(28),IS5(32),IS5(36),
D    3                      IS5(37),IS5(38),IS5(42),IS5(43),IS5(47)
D20         FORMAT(/' 1:LENGTH OF SECTION ',T56,I10,
D    1      /' 5:NUMBER OF SECTION',T60,I6,
D    2      /' 6:NUMBER OF ACTUAL DATA POINTS ',T56,I10,
D    3      /' 10:DATA REPRESENTATION TEMPLATE NUMBER ',T60,I6,
D    4      /' 12:REFERENCE VALUE ',T60,I6,
D    5      /' 16:BINARY SCALE FACTOR ',T60,I6,
D    6      /' 18:DECIMAL SCALE FACTOR ',T60,I6,
D    7      /' 20:BITS TO PACK GROUP REFERENCES',T60,I6,
D    8      /' 21:TYPE OF VALUES ',T60,I6,
D    9      /' 22:SPLITTING METHOD ',T60,I6,
D    A      /' 23:USE OF MISSING VALUES ',T60,I6,
D    B      /' 24:PRIMARY MISSING VALUE ',T60,I6,
D    C      /' 28:SECONDARY MISSING VALUE ',T60,I6,
D    D      /' 32:NUMBER OF GROUPS ',T58,I8,
D    E      /' 36:REFERENCE FOR GROUP WIDTHS ',T60,I6,
D    F      /' 37:BITS TO PACK GROUP WIDTHS ',T60,I6,
D    G      /' 38:REFERENCE FOR GROUP LENGTHS ',T60,I6,
D    H      /' 42:LENGTH INCREMENT FOR GROUP LENGTHS ',T60,I6,
D    I      /' 43:TRUE LENGTH OF LAST GROUP. ',T58,I8,
D    J      /' 47:BITS TO PACK GROUP LENGTHS ',T60,I6)
C
         ELSEIF(IS5(10).EQ.3)THEN
D           WRITE(KFILDO,10)
D15         FORMAT(/' *******************************************'
C***D           WRITE(KFILDO,10)CFEED
C***D15         FORMAT(A1,/' *******************************************'
D    1                /' DATA VALUES FOR SECTION 5 - COMPLEX PACKING'
D    2                /' WITH SECOND ORDER DIFFERENCES'
D    3                /' *******************************************')
D           WRITE(KFILDO,20)IS5(1),IS5(5),IS5(6),IS5(10),IS5(12),
D    1                      IS5(16),IS5(18),IS5(20),IS5(21),IS5(22),
D    2                      IS5(23),IS5(24),IS5(28),IS5(32),IS5(36),
D    3                      IS5(37),IS5(38),IS5(42),IS5(43),IS5(47)
         ENDIF
C
C           WRITE IS5(48) AND IS(49) THAT ONLY PERTAIN TO SECOND ORDER
C           DIFFERENCING.
C
D        IF(IS5(10).EQ.3)THEN
D           WRITE(KFILDO,25)IS5(48),IS5(49)
D25         FORMAT(' 48:ORDER OF SPATIAL DIFFERENCING ',T60,I6,
D    1      /' 49:FIELD WIDTH OF SPATIAL DESCRIPTORS ',T60,I6)
D        ENDIF
C
D        IF(IS5(10).EQ.2)THEN
D           WRITE(KFILDO,30)
D30         FORMAT(/' *******************************************'
C***D           WRITE(KFILDO,30)CFEED
C***D30         FORMAT(A1,/' *******************************************'
D    1                /' DATA VALUES FOR SECTION 7 - COMPLEX PACKING'
D    3                /' *******************************************')
D           WRITE(KFILDO,40)IS7(1),IS7(5)
D40         FORMAT(/' 1:THE NUMBER OF OCTETS IN THIS FIELD ',T57,I9,
D    1             /' 5:THE NUMBER OF THIS SECTION',T60,I6)
D        ELSEIF(IS5(10).EQ.3)THEN
D           WRITE(KFILDO,45)
D45         FORMAT(/' *******************************************'
C***D           WRITE(KFILDO,45)CFEED
C***D45         FORMAT(A1,/' *******************************************'
D    1                /' DATA VALUES FOR SECTION 7 - COMPLEX PACKING'
D    2                /' WITH SECOND ORDER DIFFERENCES'
D    3                /' *******************************************')
D           WRITE(KFILDO,50)IS7(1),IS7(5),IS7(6),IS7(7),IS7(8)
D50         FORMAT(/' 1:THE NUMBER OF OCTETS IN THIS FIELD ',T57,I9,
D    1             /' 5:THE NUMBER OF THIS SECTION',T60,I6,
D    2             /' 6:THE FIRST ORIGINAL VALUE IN THE FIELD ',T58,I8,
D    3             /' 7:THE SECOND ORIGINAL VALUE IN THE FIELD ',T58,I8,
D    4             /' 8:THE OVERALL MIN OF THE 2ND ORDER DIFF ',T58,I8)
D        ELSEIF(IS5(10).EQ.0)THEN
D           WRITE(KFILDO,47)
D47         FORMAT(/' *******************************************'
C***D           WRITE(KFILDO,47)CFEED
C***D47         FORMAT(A1,/' *******************************************'
D    1                /' DATA VALUES FOR SECTION 7 - SIMPLE PACKING'
D    3                /' *******************************************')
D           WRITE(KFILDO,55)IS7(1),IS7(5)
D55         FORMAT(/' 1:THE NUMBER OF OCTETS IN THIS FIELD ',T57,I9,
D    1             /' 5:THE NUMBER OF THIS SECTION',T60,I6)
C
D        ENDIF
C
      ENDIF
C
C         ERROR RETURN SECTION
 900  IF(IER.NE.0)THEN
C
         IF(ISEVERE.EQ.2)THEN
C              FOR A SEVERE ERROR, THE SECTION NUMBER IS SET = 99
C              SO THAT UNPACKING WILL NOT OCCUR.
            IERS=IER
            CALL PKBG(KFILDO,IPACK,ND5,LOCNS,IPOSS,99,8,N,IER,*900)
            IER=IERS
            RETURN 1
         ENDIF
C
      ENDIF
C
      IF(IERSAV.NE.0)THEN
         IER=IERSAV
         ISEVERE=1
C           THIS PROVIDES FOR NON FATAL ERROR RETURNS.
      ENDIF
C
      RETURN
      END


      SUBROUTINE leeshdr( ishot_hr, ishot_min, shot_sec,
     &    ifix_hr, ifix_min, fix_sec,
     &    dlat, dlong, wdepth, rmaggie)
c****  Decode Lee Ellett's Geometrics External header.
c   05-02-19,06:34:26,063424.35,-050 15 58.0260,-163 34 15.1560,1.0,115.2,009.8,4969,055757.411
c   06-09-06,03:03:11,030310,026 10.9520,-110 24.1460,2.1,207.0,5.9N, 2275.2

c      segddex put the line in "cbufin" for getokec(arg1,arg2).
c      getokec returns the token (delimited by commas) in arg 1.
c              arg 2 is the number of characters in the token.
c
c   mod Nov 13, 2006 - The format has changed.
c
      REAL*8 dlat, dlong, dtemp

      CHARACTER*82 out

      CALL getokec( out, n )
      CALL getokec( out, n )
      IF( out(3:3) .NE. ':' .OR. out(6:6) .NE. ':' ) THEN
          PRINT *,' Bad time in Lee header.'
          ishot_hr = 0
          ishot_min = 0
          shot_sec = 0
          ifix_hr = 0
          ifix_min = 0
          fix_sec = 0
          dlat = 0.
          dlong = 0.
          wdepth = 0.
          rmaggie = 0.
          RETURN
      ENDIF
      READ ( out, '(I2,1x,I2,1x,F2.0)' ) ishot_hr, ishot_min, shot_sec
      CALL getokec( out, n )
c      READ ( out, '(I2,I2,F7.2)' ) ifix_hr, ifix_min, fix_sec
      CALL dcode( out(1:1), 2, areal, istat )
      ifix_hr = NINT(areal)
      CALL dcode( out(3:3), 2, areal, istat )
      ifix_min = NINT(areal)
      CALL dcode( out(5:5), n-4, fix_sec, istat )
      CALL getokec( out, n )
c**** you can't add minutes to a neg lat, so save the sign.
      sign = +1.
      CALL dcode( out, n, areal, istat )
      IF( out(1:1) .EQ. '-' ) THEN
          sign = -1.
          areal = -areal
      ENDIF
      dlat = areal
      CALL getokec( out, n )
      CALL dcode( out, n, areal, istat )
      dtemp = areal
c****  It's now in floating point minutes like the GGA string - no seconds
c      CALL getokec( out, n )
c      CALL dcode( out, n, sec, istat )
c**** 60min =1deg, 60sec = 1min, 60*60sec = 1deg
c      dlat = dlat + dtemp / 60.D0 + sec / 3600.D0
      dlat = dlat + dtemp / 60.D0
      IF( sign .LT. 0. ) dlat = -dlat
      CALL getokec( out, n )
      sign = +1.
      CALL dcode( out, n, areal, istat )
      IF( out(1:1) .EQ. '-' ) THEN
          sign = -1.
          areal = -areal
      ENDIF
      dlong = areal
      CALL getokec( out, n )
      CALL dcode( out, n, areal, istat )
      dtemp = areal
c      CALL getokec( out, n )
c      CALL dcode( out, n, sec, istat )
c      dlong = dlong + dtemp / 60.D0 + sec / 3600.D0
      dlong = dlong + dtemp / 60.D0
      IF( sign .LT. 0. ) dlong = -dlong
      IF( out(1:1) .EQ. '-' ) dlong = -dlong
      CALL getokec( out, n )
      CALL dcode( out, n, hdop, istat )
      CALL getokec( out, n )
      CALL dcode( out, n, cog, istat )
      CALL getokec( out, n )
c      CALL dcode( out, n, sog, istat )
      CALL getokec( out, n )
      IF( n .GT. 6 ) THEN
          n = 6
          CALL dcode( out, n, wdepth, istat )
      ELSE
          CALL dcode( out, n, wdepth, istat )
          CALL getokec( out, n )
c**** it's terminated with cr/lf rather than null!
          CALL dcode( out, n-2, rmaggie, istat )
      ENDIF
      RETURN

      END


c
c
c     ###################################################
c     ##  COPYRIGHT (C)  1990  by  Jay William Ponder  ##
c     ##              All Rights Reserved              ##
c     ###################################################
c
c     ##################################################################
c     ##                                                              ##
c     ##  subroutine gradient  --  find energy & gradient components  ##
c     ##                                                              ##
c     ##################################################################
c
c
c     "gradient" calls subroutines to calculate the potential energy
c     and first derivatives with respect to Cartesian coordinates
c
c
      subroutine gradient (energy,derivs)
      implicit none
      include 'sizes.i'
      include 'atoms.i'
      include 'bound.i'
      include 'cutoff.i'
      include 'deriv.i'
      include 'energi.i'
      include 'inter.i'
      include 'iounit.i'
      include 'potent.i'
      include 'rigid.i'
      include 'vdwpot.i'
      include 'virial.i'
      integer i,j
      real*8 energy,cutoff
      real*8 derivs(3,*)
c
c
c     zero out each of the potential energy components
c
      eb = 0.0d0
      ea = 0.0d0
      eba = 0.0d0
      eub = 0.0d0
      eaa = 0.0d0
      eopb = 0.0d0
      eopd = 0.0d0
      eid = 0.0d0
      eit = 0.0d0
      et = 0.0d0
      ept = 0.0d0
      ebt = 0.0d0
      ett = 0.0d0
      ev = 0.0d0
      ec = 0.0d0
      ecd = 0.0d0
      ed = 0.0d0
      em = 0.0d0
      ep = 0.0d0
      er = 0.0d0
      es = 0.0d0
      elf = 0.0d0
      eg = 0.0d0
      ex = 0.0d0
c
c     zero out each of the first derivative components
c
      do i = 1, n
         do j = 1, 3
            deb(j,i) = 0.0d0
            dea(j,i) = 0.0d0
            deba(j,i) = 0.0d0
            deub(j,i) = 0.0d0
            deaa(j,i) = 0.0d0
            deopb(j,i) = 0.0d0
            deopd(j,i) = 0.0d0
            deid(j,i) = 0.0d0
            deit(j,i) = 0.0d0
            det(j,i) = 0.0d0
            dept(j,i) = 0.0d0
            debt(j,i) = 0.0d0
            dett(j,i) = 0.0d0
            dev(j,i) = 0.0d0
            dec(j,i) = 0.0d0
            decd(j,i) = 0.0d0
            ded(j,i) = 0.0d0
            dem(j,i) = 0.0d0
            dep(j,i) = 0.0d0
            der(j,i) = 0.0d0
            des(j,i) = 0.0d0
            delf(j,i) = 0.0d0
            deg(j,i) = 0.0d0
            dex(j,i) = 0.0d0
         end do
      end do
c
c     zero out the virial and the intermolecular energy
c
      do i = 1, 3
         do j = 1, 3
            vir(j,i) = 0.0d0
         end do
      end do
      einter = 0.0d0
c
c     maintain any periodic boundary conditions
c
      if (use_bounds .and. .not.use_rigid)  call bounds
c
c     update the pairwise interaction neighbor lists
c
      if (use_list)  call nblist
c
c     remove any previous use of the replicates method
c
      cutoff = 0.0d0
      call replica (cutoff)
c
c     many implicit solvation models require Born radii
c
      if (use_born)  call born
c
c     alter bond and torsion constants for pisystem
c
      if (use_orbit)  call picalc
c
c     call the local geometry energy and gradient routines
c
      if (use_bond)  call ebond1
      if (use_angle)  call eangle1
      if (use_strbnd)  call estrbnd1
      if (use_urey)  call eurey1
      if (use_angang)  call eangang1
      if (use_opbend)  call eopbend1
      if (use_opdist)  call eopdist1
      if (use_improp)  call eimprop1
      if (use_imptor)  call eimptor1
      if (use_tors)  call etors1
      if (use_pitors)  call epitors1
      if (use_strtor)  call estrtor1
      if (use_tortor)  call etortor1
c
c     call the van der Waals energy and gradient routines
c
      if (use_vdw) then
         if (vdwtyp .eq. 'LENNARD-JONES')  call elj1
         if (vdwtyp .eq. 'BUCKINGHAM')  call ebuck1
         if (vdwtyp .eq. 'MM3-HBOND')  call emm3hb1
         if (vdwtyp .eq. 'BUFFERED-14-7')  call ehal1
         if (vdwtyp .eq. 'GAUSSIAN')  call egauss1
      end if
c
c     call the electrostatic energy and gradient routines
c
      if (use_charge)  call echarge1
      if (use_chgdpl)  call echgdpl1
      if (use_dipole)  call edipole1
      if (use_mpole .or. use_polar)  call empole1
      if (use_rxnfld)  call erxnfld1
c
c     call any miscellaneous energy and gradient routines
c
      if (use_solv)  call esolv1
      if (use_metal)  call emetal1
      if (use_geom)  call egeom1
      if (use_extra)  call extra1
c
c     sum up to get the total energy and first derivatives
c
      esum = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit
     &          + et + ept + ebt + ett + ev + ec + ecd + ed + em
     &          + ep + er + es + elf + eg + ex
      energy = esum
      do i = 1, n
         do j = 1, 3
            desum(j,i) = deb(j,i) + dea(j,i) + deba(j,i)
     &                      + deub(j,i) + deaa(j,i) + deopb(j,i)
     &                      + deopd(j,i) + deid(j,i) + deit(j,i)
     &                      + det(j,i) + dept(j,i) + debt(j,i)
     &                      + dett(j,i) + dev(j,i) + dec(j,i)
     &                      + decd(j,i) + ded(j,i) + dem(j,i)
     &                      + dep(j,i) + der(j,i) + des(j,i)
     &                      + delf(j,i) + deg(j,i) + dex(j,i)
            derivs(j,i) = desum(j,i)
         end do
      end do
c
c     check for an illegal value for the total energy
c
      if (isnan(esum)) then
         write (iout,10)
   10    format (/,' GRADIENT  --  Illegal Value for the Total',
     &              ' Potential Energy')
         call fatal
      end if
      return
      end


C 	Copyright restrictions apply - see stsdas$copyright.stsdas
C
        SUBROUTINE YRCCG2(CCG2,DET,TAU1,THRESH,Q0,Q1,F,RSAT,
     *                    R20,R5,PEDGRE,DESCRP,ISTAT)
*
*  Module number:
*
*  Module name: YRCCG2
*
*  Keyphrase:
*  ----------
*       read paired pulse relation table CCG2.
*
*  Description:
*  ------------
*       This routine reads the paired pulse coefficient table.
*       Values for the FOS row with the sepcified detector are returned.
*
*  FORTRAN name: YRCCG2.for
*
*  Keywords of accessed files and tables:
*  --------------------------------------
*  Name                         I/O     Description / Comments
*       ccg2                    I       table containing CCG2 coeffecients
*  Subroutines Called:
*  -------------------
*  CDBS
*       ymsput
*  SDAS:
*       uttopn, utpgti, utcfnd, utrgt*, uttclo
*
*  History:
*  --------
*  Version      Date        Author          Description
*       1       July 89  D. Lindler      Designed and coded
*	2	Mar 94	 H. Bushouse	 Mods to handle PEDIGREE keywords
*-------------------------------------------------------------------------------
*
* Input parameters
*
*       CCG2 - table name
*       DET  - detector name ('AMBER' or 'BLUE')
*
* Output parameters
*
*       TAU1 - Time constant for first paired pulse formation
*       THRESH - Count rate threshold for paired pulse correction
*       Q0 - zeroth order constant for computing tau2
*       Q1 - first order constant for computing tau2
*       F - theshold used to compute linear varying tau2
*       RSAT - saturation input count rate level
*	R20 - count rate for 20% error in paired pulse correction
*	R5 - count rate for 5% error in correction
*	PEDGRE - CCG2 PEDIGREE keyword string
*	DESCRP - CCG2 DESCRIP  keyword string
*       ISTAT - error status
*
*-----------------------------------------------------------------------------
        INTEGER ISTAT
        REAL TAU1,THRESH,Q0,Q1,F,RSAT,R5,R20
        CHARACTER*64 CCG2
        CHARACTER*5 DET
	CHARACTER*68 PEDGRE,DESCRP
C
C     FILE I/O ACCESS MODES
C
      INTEGER   RDONLY
      PARAMETER (RDONLY = 1)
C
C     UMSPUT DESTINATIONS -- CB, DAO, 4-SEP-87
C
      INTEGER STDOUT
      PARAMETER (STDOUT = 1)
      INTEGER STDERR
      PARAMETER (STDERR = 2)
C
C     THESE MAY BE READ BY UTPGTI BUT MAY NOT BE SET:
C
C                                       NUMBER OF ROWS WRITTEN TO
      INTEGER   TBNROW
      PARAMETER (TBNROW = 21)
C     END IRAF77.INC
C
C local variables
C
        INTEGER IDIN,COLIDS(10),ROW,IDET,INTD,I,ISTATS(10),NROWS
        CHARACTER*80 CONTXT
        CHARACTER*15 COLNAM(10)
        CHARACTER*3 INST
        LOGICAL NULL
        DATA COLNAM/'INSTRUMENT','DETECTOR','TAU1','THRESHOLD','Q0',
     *                  'Q1','F','RSAT','R20','R5'/
C
C---------------------------------------------------------------------------
C
C determine detector number
C
        INTD=0
        IF(DET.EQ.'AMBER')INTD=1
        IF(DET.EQ.'BLUE')INTD=2
        IF(INTD.EQ.0)THEN
                WRITE(CONTXT,88)DET
88              FORMAT('ERROR: Invalid detector name = ',A5)
                GO TO 998
        ENDIF
C
C Open table
C
        CALL UTTOPN(CCG2,RDONLY,IDIN,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR opening CCG2 table '//CCG2
                GO TO 998
        ENDIF
C
C get PEDIGREE and DESCRIP header keywords
C
        CALL UTHGTT(IDIN,'PEDIGREE',PEDGRE,ISTAT)
        CALL UTHGTT(IDIN,'DESCRIP',DESCRP,ISTAT)
C
C get number of rows
C
        CALL UTPGTI(IDIN,TBNROW,NROWS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR reading CCG2 table '//CCG2
                GO TO 999
        ENDIF
C
C Get column ids.
C
        CALL UTCFND(IDIN,COLNAM,10,COLIDS,ISTAT)
        IF(ISTAT.NE.0)THEN
                CONTXT='ERROR locating needed columns in CCG2 table '//
     *                  CCG2
                GO TO 999
        ENDIF
C
C Locate row with correct detector number and instrument
C
        DO 10 ROW=1,NROWS
                CALL UTRGTT(IDIN,COLIDS(1),1,ROW,INST,NULL,ISTATS(1))
                CALL UTRGTI(IDIN,COLIDS(2),1,ROW,IDET,NULL,ISTATS(2))
                IF((ISTATS(1).NE.0).OR.(ISTATS(2).NE.0))THEN
                        CONTXT='ERROR reading CCG2 table '//CCG2
                        GO TO 999
                ENDIF
                IF((INTD.EQ.IDET).AND.(INST.EQ.'FOS'))GO TO 20
10      CONTINUE
C
C if we made it here, we did not find a correct row
C
        WRITE(CONTXT,99)INTD
99      FORMAT('ERROR no row in CCG2 table found for FOS detector ',I2)
        GO TO 999
C
C read values
C
20      CALL UTRGTR(IDIN,COLIDS(3),1,ROW,TAU1,NULL,ISTATS(1))
        CALL UTRGTR(IDIN,COLIDS(4),1,ROW,THRESH,NULL,ISTATS(2))
        CALL UTRGTR(IDIN,COLIDS(5),1,ROW,Q0,NULL,ISTATS(3))
        CALL UTRGTR(IDIN,COLIDS(6),1,ROW,Q1,NULL,ISTATS(4))
        CALL UTRGTR(IDIN,COLIDS(7),1,ROW,F,NULL,ISTATS(5))
        CALL UTRGTR(IDIN,COLIDS(8),1,ROW,RSAT,NULL,ISTATS(6))
        CALL UTRGTR(IDIN,COLIDS(9),1,ROW,R20,NULL,ISTATS(7))
        CALL UTRGTR(IDIN,COLIDS(10),1,ROW,R5,NULL,ISTATS(8))
        DO 30 I=1,8
            IF(ISTATS(I).NE.0)THEN
                CONTXT='ERROR reading CCG2 table '//CCG2
                GO TO 999
            ENDIF
30      CONTINUE
C
        CALL UTTCLO(IDIN,ISTAT)
        ISTAT=0
        GO TO 1000
C
999     CALL UTTCLO(IDIN,ISTAT)
998     CALL YMSPUT(CONTXT,STDOUT+STDERR,0,ISTAT)
        ISTAT=1
1000    RETURN
        END


\ WM-Dots the Window Maker 3d Rotating Dots Demo by Mark I Manning IV
\ ------------------------------------------------------------------------

\ no this dont run in windowmaker lol

\ ------------------------------------------------------------------------

 vocabulary dots dots definitions

\ ------------------------------------------------------------------------

  fload src/examples/dots/sintab.f   \ sin and cos table
  fload src/examples/dots/shapes.f   \ simple shapes to be rotated

\ ------------------------------------------------------------------------
\ structure defining modifications to be made to parameters on the fly

struct: modifier
  1 dd m.counter            \ count down to next speed/shape change
  1 dd m.reset              \ initial value of counter
  1 dd m.ptr                \ pointer to item to modify
  1 dd m.delta              \ ammount to change item by
  1 dd m.upper              \ upper limit for item
  1 dd m.lower              \ lower limit for item
;struct

\ ------------------------------------------------------------------------
\ create nice text windows for display

  screen: main-screen       \ windows need a parent screen...

  window: backdrop          \ used to give display a border
  window: main-win          \ where everythng happens

 0 var width
 0 var height
 0 var frames
 0 var start

\ ------------------------------------------------------------------------
\ mental note to self: need to add a winch handler here somewhere

: init-windows
  main-screen scr-clr

  cols    rows     main-screen (screen:)
  cols 2- rows 3 - backdrop    (window:)
  width height     main-win    (window:)

  white black >color main-win win-color!
  white blue  >color backdrop win-color!
  cyan blue   >color backdrop win-bcolor!

  main-win >locked
  backdrop >fill            \ put a border on the backdrop window
  backdrop >borders         \ backfill window

  backdrop win-clr
  main-win win-clr          \ clear the main window

  3 2 main-win winpos!      \ center main window on backdrop
  1 1 backdrop winpos!

  main-screen backdrop win-attach      \ attach both windows to the screen
  main-screen main-win win-attach      \   structure

  main-screen .screen 3drop ;      \ draw everything

\ ------------------------------------------------------------------------

  0 var x_angle             \ angles of rotation
  0 var y_angle
  0 var z_angle

  0 var cos_x               \ sin and cosine of each angle
  0 var cos_y
  0 var cos_z
  0 var sin_x
  0 var sin_y
  0 var sin_z

  30 constant x_off         \ world coordinates of shape
  30 constant y_off
 150 constant z_off

  1 var delta_x             \ rotation speeds
  1 var delta_y
  1 var delta_z

 125 var #points
   0 var obj#
   0 var object

   0 var buffer             \ painters algorithm buffer

  create points MAX_POINTS 2* allot

\ ------------------------------------------------------------------------
\ modifiers...

create w1                   \ changes x rotation speed
  30 ,                      \ frame count down counter
  34 ,                      \ reset value for countdown counter
  ' delta_x >body ,         \ item to modify on count = 0
  1 ,                       \ ammount to add to item
  5 ,                       \ upper limit for item
  1 ,                       \ lower limit for item

create w2                   \ changes y rotation speed
  20 ,
  20 ,
  ' delta_y >body ,
  -1 ,
   5 ,
   1 ,

create w3                   \ changes z rotation speed
  40 ,
  30 ,
  ' delta_z >body ,
  1 ,
  5 ,
  1 ,

create w4                   \ zooms object in / out of window
   4 ,
   4 ,
   ' z_off >body ,
  -1 ,
 300 ,
  50 ,

\ ------------------------------------------------------------------------
\ c-mon this is a TEXT mode, what can you do with 16 colours :P

 0 var c                    \ z color of current 'pel'
 0 var ch                   \ z char  of current 'pel'
 0 var cmax

\ ------------------------------------------------------------------------
\ colors of each 'pixle' based on z coordinate

  create col
    yellow  c, blue c,     \ near pixle color
    blue    c, blue c,     \ successivly further away pixle colors
    blue    c, blue c,
    blue    c, blue c,

\ ------------------------------------------------------------------------
\ which char to use to draw pixle based on z coordinate

  create chr
    ,' @##``ff~'

create alts
   0 c, 0 c, 0 c, 1 c, 1 c, 1 c, 1 c, 1 c,

create bolds
   1 c, 1 c, 1 c, 0 c, 0 c, 0 c, 0 c, 0 c,

\ ------------------------------------------------------------------------
\ change color of 'pel' based on its z coord within the shape

: c>fg  ( color --- )
  main-win win>fg ;

 0 var alt?
 0 var bld?

\ ------------------------------------------------------------------------
\ convert z to a pixle and its color

: >c
  c 65 + 4 >> 0 max 7 min dup
  col + c@  c>fg
  dup chr + c@ !> ch
  dup alts + c@ !> alt?
      bolds + c@ !> bld? ;

\ ------------------------------------------------------------------------
\ draws one 'pel' of shape

: (draw_point)      ( x y --- )
  2dup width * +

  buffer + c@               \ fetch pel already drawn here
  c u>                      \ closer in than new pel?
  if
    2drop exit              \ if not then dont draw it
  then

  over $ff =                \ is point clipped?
  over $ff = or
  if
    2drop exit
  then

  main-win alt? ?: win>alt win<alt
  main-win bld? ?: win>bold win<bold

  swap main-win win-at

  ch main-win wemit ;

\ ------------------------------------------------------------------------
\ draw a point at x/y in specified colour

: draw_point  ( x y --- ) >c (draw_point) ;
: erase_point ( x y --- ) bl !> ch white c>fg (draw_point) ;

\ ------------------------------------------------------------------------
\ clear frame history buffers

: clr_points
  points [ MAX_POINTS 2* ]#
  $ff fill ;

\ -----------------------------------------------------------------------
\ erase points that are 3 frames old. shift frame histories

: clr_frame
  MAX_POINTS
  for
    points r@ 2* +
    count swap c@
    erase_point
  nxt ;

\ ------------------------------------------------------------------------

: sin@  ( angle --- sin ) 2* sin_tab + w@ 16 << 16 >> ;
: cos@  ( angle --- cos ) $80 + $1ff and sin@ ;

\ ------------------------------------------------------------------------
\ pre calculate sin and cosine values for x y and z angles of rotation

: sincos
  x_angle sin@ !> sin_x
  y_angle sin@ !> sin_y
  z_angle sin@ !> sin_z

  x_angle cos@ !> cos_x
  y_angle cos@ !> cos_y
  z_angle cos@ !> cos_z ;

\ ------------------------------------------------------------------------

\ : rotate    ( coord1 coord2 cos sin --- ) ;

\ ------------------------------------------------------------------------
\ rotate point by x angle

: x_rotate      ( y z --- y' z' )
  over cos_x * over sin_x * swap - 14 >> >r
       cos_x * swap sin_x *      + 14 >> r> ;

\ ------------------------------------------------------------------------

: y_rotate      ( z x --- z' x' )
  over sin_y * over cos_y * swap - 14 >> >r
       sin_y * swap cos_y *      + 14 >> r> ;

\ -----------------------------------------------------------------------

: z_rotate      ( x y --- x' y' )
  over cos_z * over sin_z * swap - 14 >> >r
       cos_z * swap sin_z *      + 14 >> r> ;

\ -----------------------------------------------------------------------
\ roatate object about x y and z axis (in object space)

: rotate        ( x y z --- xx yy zz )
  x_rotate rot
  y_rotate rot
  z_rotate rot ;

\ -----------------------------------------------------------------------
\ my / word does not pre-test for divide by zero

: /+ ( n1 n2 n3 --- n4 )
  -rot dup 0>
  if
    swap 6 << swap /
    32 + 6 >> +
  else
    3drop -1
  then ;

\ ------------------------------------------------------------------------
\ project point in 3d space onto plane in 2d space

: project       ( x y z --- xx yy )
  swap y_off *
  over z_off +
  height 2/ /+

  dup 0 height within not
  if
    3drop $ff $ff exit
  then

  -rot

  swap x_off *
  swap z_off +
  width 2/ /+

  dup 0 width within not
  if
    2drop $ff $ff
  then

  swap ;

\ ------------------------------------------------------------------------
\ fetch 8 bit signed data, convert to 32 bit signed data

: (xyz)     ( a1 --- n1 a1++ )
  count 24 << 24 >> swap ;

\ ------------------------------------------------------------------------

: xyz@      ( index --- x y z )
  3 * object +
  (xyz) (xyz) (xyz) drop ;

\ ------------------------------------------------------------------------

: (do-frame)        ( index --- index' )
  dup>r xyz@                \ fetch next coordinate from shape
  rotate dup !> c           \ rotate and project this point
  project                   \ project point into 2d space
  2dup draw_point           \ draw this point
  r@ 2* points +            \ save this point
  tuck 1+ c! c!
  r> 1+
  incr> frames ;

\ ------------------------------------------------------------------------

  0 var fps

: .fps
  cyan >bg white >fg >bold
  2 3 at ."  fps:" fps .
  black >bg white >fg ;

\ ------------------------------------------------------------------------

: ?frame-rate
  localtime start - 5 < ?exit
  frames 5 / !> fps
  off> frames localtime !> start ;

\ ------------------------------------------------------------------------
\ draw one frame of object...

: do_frame
  ?frame-rate .fps
  buffer rows cols * erase
  sincos                    \ calculate all sin/cos values

  0                         \ initial index
  #points rep (do-frame)    \ rotate/project indexed point and index++
  drop                      \ discard index when all points rotated etc
  main-screen .screen ;     \ display updated frame

\ ------------------------------------------------------------------------
\ adjust rotational speeds / distance between min and max for each

: modify    ( modifier --- )
  dup>r m.counter dup       \ count down to modification
  decr @
  if
    r>drop exit             \ not time yet...
  then

  r@ m.reset @              \ reset counter to initial value
  r@ m.counter !

  r@ m.delta @              \ add delta to variable to modify
  r@ m.ptr tuck @ +! @ @    \ fetch new value of variable

  dup r@ m.lower @ > not    \ within range ?
  swap r@ m.upper @ < not or
  if
    r@ m.delta dup @        \ if not then negate the delta
    negate swap !
  then

  r>drop ;

\ ------------------------------------------------------------------------
\ do the above on each of the 4 modifiers

: do_deltas
  w1 modify                  \ modify x rotational speed
  w2 modify                  \ modify y rotational speed
  w3 modify                  \ modify z rotational speed
  w4 modify ;                \ zoom shape in and out

\ ------------------------------------------------------------------------
\ adjust x y and z angles of rotation for next frame

: change_angles
  delta_x x_angle + $1ff and !> x_angle
  delta_y y_angle + $1ff and !> y_angle
  delta_z z_angle + $1ff and !> z_angle ;

\ ------------------------------------------------------------------------

: select-obj
  obj# cells 2* obj_list +
  dup @ !> #points
  cell+ @ !> object ;

\ ------------------------------------------------------------------------

: (main)        ( --- f1 )
  select-obj
  1500
  for
    change_angles         \ adjust angles of rotation
    clr_frame             \ clear pels that are 2 frames old
    do_frame              \ draw object
    do_deltas             \ modify rotation speeds etc
    key?
    if
      r>drop key bl <> exit
    then
    z_off 5 >> 15 + ms
  nxt
  false ;

\ ------------------------------------------------------------------------

: obj++
  incr> obj#
  obj# NUM_OBJECTS =
  if
    off> obj#
  then ;

\ ------------------------------------------------------------------------

: main
  cols 6 - !> width         \ define width and height of main window
  rows 5 - !> height

  clear init-windows
  width height * allocate
  drop !> buffer
  curoff clr_points         \ clear frame history buffers
  localtime !> start
  begin
    (main) obj++
  until
  curon
  clear rows 1- 0 at
  ( bye ) ;                \ put this bye back in if turnkeying

\ ------------------------------------------------------------------------
\ to create a stand alone turnkey demo do this

\ but first create a stripped down version of src/xr.f to compile
\ these sources against

\  ' main is quit
\  turnkey dots

\  =======================================================================


subroutine reorg_metar_cloud(cdata,nreal,ndata,cdata_all,maxobs,ngrid)
!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:  reorg_metar_cloud     define a closest METAR cloud observation for each grid point
!
!   PRGMMR: Ming Hu          ORG: GSD/AMB        DATE: 2009-09-21
!
! ABSTRACT:
!
! PROGRAM HISTORY LOG:
!    2010-04-21  Hu  initial
!    2011-10-21  Hu  add code to delete dust and haze report
!    2015-08-06  S.Liu cross-check low cloud and T-Td and reject
!                low cloud if T-Td > 2.0 deg
!    2016-06-21  S.Liu give number precision
!
!  input argument list:
!     cdata     - METRA cloud observation
!     nreal     - first dimension of cdata
!     ndata     - second dimension of cdata
!     maxobs    - maximum number of cdata_all
!     ndata     - number of type "obstype" observations retained for further processing
!
!  output argument list:
!     cdata_all - reorganized METAR observation
!     ngrid     - number of type metar cloud observations reorganized to the grid
!
! USAGE:
!   INPUT FILES:
!   OUTPUT FILES:
!
! REMARKS:
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!   MACHINE:  Linux cluster (WJET)
!
!$$$
!
!_____________________________________________________________________
!

  use kinds, only: r_kind,i_kind,r_double
  use gridmod, only: nlon,nlat
  use constants, only: one,half
  use rapidrefresh_cldsurf_mod, only: metar_impact_radius

  implicit none

! Declare passed variables
  integer(i_kind)                       ,intent(in) :: nreal
  integer(i_kind)                       ,intent(in) :: ndata
  integer(i_kind)                       ,intent(in) :: maxobs
  real(r_kind),dimension(nreal,ndata)   ,intent(inout) :: cdata
  real(r_kind),dimension(nreal,maxobs)  ,intent(out):: cdata_all
  integer(i_kind)                       ,intent(out):: ngrid

! local variable
!
  integer(i_kind) :: ista_prev,ista_prev2,ista_save

  INTEGER(i_kind),allocatable :: first_sta(:,:)
  INTEGER(i_kind),allocatable :: next_sta(:)
  INTEGER(i_kind) ::    null_p
  PARAMETER ( null_p     = -1       )

  INTEGER(i_kind)  :: nsta_cld
  INTEGER(i_kind),allocatable :: sta_cld(:)

  integer(i_kind) :: isprd,isprd2,iout
  integer(i_kind) ::  aninc_cld_p
  integer(i_kind) :: i,j,k,i1,j1,ic,ista
  integer(i_kind) ::  ista_min
  real(r_kind) ::  min_dist, dist
  real(r_kind) ::  awx, cg_dewpdep, cldamt,cldhgt,cl_base_ista
  real(r_kind) ::  cl_mt_ista
  integer(i_kind) ::  idust,ihaze

  real(r_double) rstation_id
  character(8) :: cstation1,cc,ci
  equivalence(cstation1,rstation_id)

  real(r_kind)    ::     spval_p
  parameter (spval_p = 99999._r_kind)

!
!
  isprd=int(metar_impact_radius + half)
  if(isprd <= 0) return
  if(ndata <= 0) return
  ngrid = 0
  aninc_cld_p = isprd
  isprd2      = isprd * isprd
!
!  check duplicate observation and pick the one near analyis time
!
  DO i=1,ndata-1
    DO ic = i+1, ndata
      rstation_id=cdata(1,ic)
      cc=cstation1
      rstation_id=cdata(1,i)
      ci=cstation1
      if(trim(cc) == trim(ci) ) then
        if(abs(cdata(21,ic)) >= abs(cdata(21,i))) then   ! 21= observation time
          cdata(22,ic)=100.0_r_kind                               ! 22= usage
        else
          cdata(22,i)=100.0_r_kind
        endif
      endif
    ENDDO  !  ic
  ENDDO  !  i
!
! Check Haze and Dust station
!
  DO i=1,ndata
     rstation_id=cdata(1,i)
     cc=cstation1

     if(cdata(22,i) < 50 ) then
        idust=0
        ihaze=0
        DO j=1,3
           awx  = cdata(17+j,i)        ! weather
           if(awx==5._r_kind  .or. awx==105._r_kind .or. awx==104._r_kind) ihaze=ihaze+1
           if( (awx >=6._r_kind .and. awx <= 9._r_kind) .or.     &
               (awx >=30._r_kind .and. awx <= 35._r_kind) .or.   &
               (awx ==76._r_kind .or. awx == 111._r_kind)        &
             )     idust=idust+1
        ENDDO ! j

!* check cloud base and T-Td
           cl_base_ista=spval_p
           DO j=1,3
              cldamt =  cdata(5+j,i)         ! cloud amount
              cldhgt =  int(cdata(11+j,i))   ! cloud bottom height
              if(abs(cldamt) < spval_p .and. abs(cldhgt) < spval_p) then
                 if(cl_base_ista>cldhgt)then
                 if( (cldamt > 3.5_r_kind .and. cldamt < 9.5_r_kind ) .or.  abs(cldamt-12._r_kind) < 0.0001_r_kind  ) then
                    cl_base_ista = cldhgt
                    cl_mt_ista = cldamt
                 endif ! cloud ceiling
                 endif
              endif
           ENDDO ! j

!* case1: low cloud with full coverage, but saturation height derived from T-Td(>1.5 deg) > 150
        if(cl_base_ista < 100.0_r_kind                             .and. &
           cl_mt_ista>6.0_r_kind .and. cl_mt_ista < 9.5_r_kind .and. &
           cdata(24,i)>2.5 ) then
           cdata(22,i)=200
           write(6,*)'block station::',cc
        end if

        if(ihaze > 0 .or. idust > 0 ) then
!           write(*,'(a,a8,3F10.1)') 'dust or haze report at station ',rstation_id, (cdata(17+j,i),j=1,1)
           cg_dewpdep = 100._r_kind * cdata(24,i)  ! 100. = dry adiabatic lapse rate in m/K
           DO j=1,3
              cldamt =  cdata(5+j,i)         ! cloud amount
              cldhgt =  int(cdata(11+j,i))   ! cloud bottom height
              if(abs(cldamt) < spval_p .and. abs(cldhgt) < spval_p) then
                 if( (cldamt > 3.5_r_kind .and. cldamt < 9.5_r_kind ) .or. abs(cldamt-12._r_kind) < 0.0001_r_kind  ) then
                    cl_base_ista = cldhgt
!   Check - compare estimated cloud base from dewpoint depression (calc above as cg_dewpdep)
!             with ceiling height AGL.  We allow a slop room of 200m extra.  Stan B. and John B.-31Aug2011
                    if (cg_dewpdep > -10._r_kind .and. (cg_dewpdep-300._r_kind > cl_base_ista )) then
                       cdata(22,i)=200
                       write (6,'(a,a,3(a,f10.1))') 'Dust-ceiling IDed ', rstation_id,   &
                                     ' dewpoint depr *100=',cg_dewpdep, 'ceiling=',cl_base_ista
                    end if
                    if (cg_dewpdep < -990._r_kind) then
                       cdata(22,i)=200
                       write (6,*) 'Dust-ceiling possible, could not calc dewpoint, do not use ceiling ',rstation_id
                    end if
                 endif ! cloud ceiling
              endif
           ENDDO ! j
        endif  ! ihaze > 0 .or. idust > 0
     endif
  ENDDO  !  i

!
!
!  find the nearest METAR station for each grid point
!
  allocate(first_sta(nlon,nlat))
  allocate(next_sta(ndata))
  allocate(sta_cld(ndata))
  first_sta= null_p
  next_sta = null_p
  sta_cld  = 0

! -- Then fill arrays based on where obs are
! -- NEXT_STA  - pointer to next ob found in grid volume
!         from the previous ob in that volume
!-----------------------------------------------------------
  do ista = 1,ndata
     if (cdata(22,ista) < 50) then
       if (cdata(6,ista) >= -one .and. cdata(6,ista) < 100.0_r_kind) then
! when cloud data are available

          i = int(cdata(2,ista))
          j = int(cdata(3,ista))

          if (first_sta(i,j) == null_p) then
             first_sta(i,j) = ista
          else
             ista_prev = first_sta(i,j)
             do while (ista_prev /= null_p )
                ista_prev2= next_sta(ista_prev)
                ista_save = ista_prev
                ista_prev = ista_prev2
             enddo
             next_sta(ista_save) = ista
          end if
       endif
     endif
   enddo

   iout=0
   DO j = 1,nlat,aninc_cld_p
     DO i = 1,nlon,aninc_cld_p
       nsta_cld = 0

!sb -- Find all stations w/ cloud data within encompassing box
!mh   The box is decide by the influence radius of the analysis
       do j1 = max(1,j-isprd),min(nlat,j+aninc_cld_p+isprd)
         do i1 = max(1,i-isprd),min(nlon,i+aninc_cld_p+isprd)
           if (first_sta(i1,j1) /= null_p) then
              ista_prev = first_sta(i1,j1)
              do while (ista_prev /= null_p )
                 nsta_cld = nsta_cld + 1
                 sta_cld(nsta_cld) = ista_prev
                 ista_prev2= next_sta(ista_prev)
                 ista_prev = ista_prev2
              enddo
           end if
         enddo   ! j1
       enddo   ! i1

!
!sb - This is the big grid pt loop.  Walk thru each
!            individual grid points within 10x10 box.
       if(nsta_cld > 0 ) then
         do j1 = j,min(nlat,j+aninc_cld_p - 1)
           do i1 = i,min(nlon,i+aninc_cld_p - 1)

!sb - Find closest cloud station to grid point
             min_dist = 1.e10_r_kind
             do ic= 1,nsta_cld
                ista = sta_cld(ic)
                dist = (float(i1)-cdata(2,ista))*(float(i1)-cdata(2,ista))  &
                      +(float(j1)-cdata(3,ista))*(float(j1)-cdata(3,ista))
                if (dist < min_dist .and. dist < float(isprd2)) then
                    min_dist = dist
                    ista_min = ista
                end if
             end do  ! ic find the closest cloud station

             if (min_dist < 1.e9_r_kind) then
                if (i1 > 1 .and. i1  < nlon .and. j1 > 1 .and. j1 < nlat) then
                   iout = iout + 1
                   if(iout > maxobs) then
                      write(6,*)'reorg_metar_cloud:  ***Error*** ndata > maxobs '
                      call stop2(50)
                   end if
                   do k=1,nreal
                      cdata_all(k,iout) = cdata(k,ista_min)
                   enddo
                   cdata_all(24,iout) = cdata_all(2,iout)   ! save observaion station i
                   cdata_all(25,iout) = cdata_all(3,iout)   ! save observaion station j
                   cdata_all(2,iout) = float(i1)        ! grid index i
                   cdata_all(3,iout) = float(j1)        ! grid index j
                   cdata_all(23,iout)=sqrt(min_dist) ! distance from station
                endif
             endif
           enddo   ! j1
         enddo   ! i1
       endif ! nsta_cld > 0
     enddo   ! j
   enddo   ! i

   ngrid = iout

   deallocate(first_sta)
   deallocate(sta_cld)
   deallocate(next_sta)

end subroutine reorg_metar_cloud