c     ****************************************************************
c     *                                                              *
c     *                      subroutine incomp                       *
c     *                                                              *
c     *                       written by : bh                        *
c     *                                                              *
c     *                   last modified : 6/15/2013 rhd              *
c     *                                                              *
c     *     performs the initial computations, data structure setup  *
c     *     necessary for first (time) step i                        *
c     *                                                              *
c     ****************************************************************
c
      subroutine incomp
      use global_data ! old common.main
      use main_data, only : incid
      implicit integer (a-z)
      double precision
     &   zero
      integer, dimension(:), allocatable ::  temp_vec
      logical local_debug
      real, external :: wcputime
      data local_debug / .false. /
      data zero / 0.0d00 /
c
c          this code has been re-written a number of
c          times as WARP3D evolved. At present, I believe
c          this routine is called only at the start of
c          solution for time step 1 and never again.
c
c          re-size the incid vector to its required size
c          rather than the maximum possible size.
c
      if( local_debug ) write(*,*) '.... inside incomp....'
c
      allocate( temp_vec(inctop),  stat = alloc_stat )
      if ( alloc_stat .ne. 0 ) then
         write(out,9900); write(out,9994); call die_abort
      end if
      temp_vec(1:inctop) = incid(1:inctop)
      call mem_allocate( 10 )
      incid(1:inctop) = temp_vec(1:inctop)
      deallocate( temp_vec )
c
c          allocate and initialize:
c            o   build an element to blocks mapping
c                data structure for general use.
c            o   deallocate the elstor table used only
c                during input.
c            o   history dependent data for elements to
c                support material nonlinearity models.
c            o   rotation matrices at gauss points to
c                support finite strain/large displacement
c                analyses.
c            o   strains for all elements
c            o   stresses for all elements
c            o   cdest indexes for all elements.
c            o   edest indexes for all elements.
c            o   volumes for all elements
c            o   vector of rigid contact forces (always)
c            o   array of contact "causes" -- only if
c                rigid contact surfaces defined
c            o   lists of solid elements connected to
c                cohesive-interface elements
c
      call init_eblock_map
      call mem_allocate( 7 )
      call history_cep_init( 0, 1 )
      call rotation_init( 0, 1 )
      call strains_init( 0, 1 )
      call stresses_init( 0, 1 )
      call cdest_init
      call edest_init
      call element_volumes_init( 0, 1 )
      call solid_cohes_init
c
c          MPI:
c             broadcast basic model, constraint, and analysis
c             parameter information to all the worker processors.
c
      if( use_mpi ) write(out,9000) wcputime(1)
      call wmpi_send_basic
      call wmpi_send_const
      call wmpi_send_analysis
      call wmpi_init_owner
      if( use_mpi ) write(out,9005) wcputime(1)
c
c          allocate space for rigid contact info
c
      call mem_allocate( 24 )
      call mem_allocate( 25 )
c
c          compute the mass matrix at time zero. as
c          required, set flag indicating that a new
c          mass for use in the iterative procedure
c          has been computed.
c
      write(out,9150)
      call cmpmas
      newmas = .true.
c
c          generate mpc equations from input tied mesh data.
c
      call tied_mesh_driver()
c
c          uexternaldb for Abaqus compatible support
c
      douextdb = 1  ! in common.main
      call wmpi_do_uexternaldb
c
c          compute the initial internal forces if not
c          done already. we now just zero them - applied
c          initial stresses at t=0 not supported.
c
      ifv(1:nodof) = zero
c
c          set flag (init computations flag) signaling
c          that initial computations-setup have been made
c
      incflg = .true.

      if( local_debug ) write(out,*) '... leaving incomp ...'
c
c
 9000 format(/,7x,
     & '>> Start MPI toplogy setup, worker init @',f10.2)
 9005 format(/,7x,
     & '>> Done MPI toplogy setup, worker init  @',f10.2)
 9150 format(/,7x,
     & '>> computing structural diagonal mass (@ t=0)')
 9900 format('>>> FATAL ERROR: memory allocate failure...')
 9994 format('                 incid re-allocate failure. incomp')
      end
c     ****************************************************************
c     *                                                              *
c     *                 subroutine tied_mesh_driver                  *
c     *                                                              *
c     *                       written by : bjb                       *
c     *                                                              *
c     *                   last modified : 9/3/2017 rhd               *
c     *                                                              *
c     *     this subroutine prepares necessary temporary data        *
c     *              to call the tied mesh processor                 *
c     *                                                              *
c     ****************************************************************

      subroutine tied_mesh_driver()
      use global_data ! old common.main
      use main_data, only : crdmap, incid, incmap
      use mod_mpc, only : tied_sets_exist, tied_con_mpcs_constructed,
     &                    surface_table, tied_contact_table,
     &                    tied_con_mpc_table
      integer  err, dimnode, dimcoord, dimelem, meshformat, nnodes,
     &         icol, dumi
      integer, allocatable, dimension (:,:) :: elemcon
      real  epsilon, dumr, wcputime
      double precision, allocatable, dimension (:,:) :: nodecoord
      character(len=1) :: dums
      double precision dumd
      external wcputime
c
      if (.not. tied_sets_exist)  return
      allocate (tied_con_mpc_table(max_mpc_tied),
     &          nodecoord(nonode,3),
     &          elemcon(noelem,mxndel), stat=err)
      if (err .ne. 0) then
         call errmsg2(58,dumi,dums,dumr,dumd)
         call die_abort
      end if
c
      do i = 1, nonode
         do j = 1, 3
            nodecoord(i,j) = 0
         end do
      end do
c
      do i = 1, nonode
         nodecoord(i,1) = c(crdmap(i))
         nodecoord(i,2) = c(crdmap(i)+1)
         nodecoord(i,3) = c(crdmap(i)+2)
      end do
c
      do i = 1, noelem
         do j = 1, mxndel
            elemcon(i,j) = 0
         end do
      end do
c
      do i = 1, noelem
         nnodes = iprops(2,i)
         icol = 0
         do j = incmap(i), incmap(i)+nnodes-1
            icol = icol + 1
            elemcon(i,icol) = incid(j)
         end do
      end do
c
      dimnode    = nonode
      dimcoord   = 3
      dimelem    = noelem
      meshformat = 2
      epsilon    = 0.000001
c
      call  tied_mainprocessor(nodecoord, dimnode, dimcoord, nonode,
     &                         elemcon, dimelem, mxndel, noelem,
     &                         cstmap, meshformat, props, out, epsilon)
      write(out,9000) wcputime(1)
c
      tied_con_mpcs_constructed = .true.
      deallocate (nodecoord,elemcon,surface_table,tied_contact_table)
c
      return
c
 9000 format(/,7x,
     & '>> tied mesh processor finished  @ ', f10.2)
c
      end


module lfmgrid

use map_utils

implicit none

save

integer, parameter :: maxdomains=10
real, parameter :: rmsg=1.e37

integer :: nx,ny,nz,lx,ly,lz,nvar2d,nvar3d,nvar3dh,nvar2dout,nvar3dout

type(proj_info) :: proj

logical :: out_cdf=.true.,out_grib=.false.,out_v5d=.true.
logical :: make_micro=.true.,make_firewx=.true.,make_points(maxdomains)=.false.
logical :: verbose=.true.
logical :: realtime=.true.
logical :: write_to_lapsdir=.true.
logical :: make_donefile=.true.
logical :: large_pgrid=.false.
logical :: large_ngrid=.false.
logical :: l_process_p=.false.
logical :: l_process_t=.false.
logical :: l_process_mr=.false.
logical :: l_process_z=.false.
logical :: l_process_uv=.false.
logical :: l_process_w=.false.

integer :: domnum,fcsttime,laps_reftime,laps_valtime,precip_dt=3600  ! in seconds
integer :: k_micro=999
integer :: n3d_pts_thr=33000000
integer :: p3d_pts_thr=22000000
integer :: advection_time = 0
integer :: i4_adv_cld = -1
integer :: i4_adv_pcp = -1

character(len=256) :: filename,filename0
character(len=32)  :: mtype
character(len=20)  :: c_m2z='rams'
character(len=3)   :: domnum_fstr
character(len=4)   :: wrf_version='3'

! Point forecast variables.

integer :: point_tz_utcoffset=0
character(len=5) :: point_vent_units='M^2/S'
character(len=3) :: point_tz_label='UTC'
character(len=3) :: point_windspd_units='KTS'
character(len=1) :: point_temp_units='F'

! Native grid map specifications.

real :: ngrid_spacingx,ngrid_spacingy,nstdlon,ntruelat1,ntruelat2
character(len=32) :: nprojection

! Laps grid map specifications.

real :: grid_spacing,stdlon,truelat1,truelat2
character(len=32) :: projection

!real, target, dimension(:,:,:) :: ngrid   ! Native model grid
!real, target, dimension(:,:,:) :: hgrid   ! Horizontally interpolated 3d grid
!real, target, dimension(:,:,:) :: pgrid   ! Isobaric output grid
!real, target, dimension(:,:,:) :: sgrid   ! Horizontally interpolated sfc output grid
real, target, allocatable, dimension(:,:,:) :: ngrid   ! Native model grid
real, target, allocatable, dimension(:,:,:) :: hgrid   ! Horizontally interpolated 3d grid
real, target, allocatable, dimension(:,:,:) :: pgrid   ! Isobaric output grid
real, target, allocatable, dimension(:,:,:) :: sgrid   ! Horizontally interpolated sfc output grid

! Native grid variables.

real, allocatable, dimension(:,:) :: nlat,nlon
real, pointer, dimension(:,:) ::  &
       nzsfc    ,npsfc    ,ntsfc    ,nmrsfc   ,nusfc     &
      ,nvsfc    ,nwsfc    ,nground_t,npblhgt  ,npcp_tot  &
      ,nlwout   ,nswout   ,nlwdown  ,nswdown  ,nshflux   &
      ,nlhflux  ,nsnowc
real, pointer, dimension(:,:,:) :: &
       npsig    ,nzsig    ,ntsig    ,nmrsig   ,nusig     &
      ,nvsig    ,nwsig    ,ntkesig                       &
      ,ncldliqmr_sig,ncldicemr_sig,nrainmr_sig,nsnowmr_sig,ngraupelmr_sig &
      ,nrefl_sig

! Horizontally interpolated grid variables.

real, pointer, dimension(:,:,:) :: &
       hpsig    ,hzsig    ,htsig    ,hmrsig   ,husig     &
      ,hvsig    ,hwsig    ,htkesig                       &
      ,hcldliqmr_sig,hcldicemr_sig,hrainmr_sig,hsnowmr_sig,hgraupelmr_sig  &
      ,hrefl_sig,hzdr_sig,hldr_sig

! Laps isobaric grid variables.

real, allocatable, dimension(:) :: lprs,lprsl
real, pointer, dimension(:,:,:) ::  &
       zprs                       ,tprs         ,shprs        ,uprs          &
      ,vprs         ,wprs         ,omprs        ,cldliqmr_prs  &
      ,cldicemr_prs ,rainmr_prs   ,snowmr_prs   ,graupelmr_prs,refl_prs      &
      ,zdr_prs      ,ldr_prs                                                 &
      ,pcptype_prs

integer,            allocatable, dimension(:) :: lvls3d
character(len=3),   allocatable, dimension(:) :: name3d
character(len=10),  allocatable, dimension(:) :: units3d
character(len=4),   allocatable, dimension(:) :: lvltype3d
character(len=132), allocatable, dimension(:) :: com3d

! Laps surface grid variables.

real, allocatable, dimension(:,:) :: llat,llon
real, pointer, dimension(:,:) ::  &
       zsfc         ,psfc         ,tsfc         ,mrsfc        ,usfc        &
      ,vsfc         ,wsfc         ,ground_t     ,pblhgt       ,rhsfc       &
      ,pcp_tot      ,thetasfc     ,ztw0         ,ztw1                      &
      ,thetaesfc    ,tdsfc        ,redp         ,pmsl         ,upbl        &
      ,vpbl         ,u80          ,v80          ,clwmrsfc     ,icemrsfc     ,snowmrsfc    ,rainmrsfc   &
      ,graupmrsfc   ,cldbase      ,cldtop       ,cldamt       ,ceiling     &
      ,intliqwater  ,intcldice    ,totpcpwater  ,max_refl     ,echo_tops    ,refl_sfc    &
      ,pcptype_sfc  ,pcp_inc      ,snow_inc     ,snow_tot     ,snow_cvr    &
      ,srhel        ,uhel         ,bshr         ,scp          ,cape         ,cin          ,liftedind   &
      ,visibility   ,heatind      ,lwout        ,swout        ,lwdown      &
      ,swdown       ,shflux       ,lhflux       ,vnt_index    ,ham_index   &
      ,hah_index    ,fwi_index    ,fwx_index    ,upflux       ,bt11u       &
      ,cldalb       ,simvis
integer,            allocatable, dimension(:) :: lvls2d
character(len=3),   allocatable, dimension(:) :: name2d
character(len=10),  allocatable, dimension(:) :: units2d
character(len=4),   allocatable, dimension(:) :: lvltype2d
character(len=132), allocatable, dimension(:) :: com2d

! Grib parameters.

integer :: table_version=2,center_id=59,subcenter_id=2,process_id=255  &
          ,funit,startbyte,nbytes,igds(18)
integer, allocatable, dimension(:) :: param,leveltype,level1,level2  &
                                     ,timerange,scalep10             &
                                     ,paramua,scalep10ua
character(len=256) :: gribfile
logical, allocatable, dimension(:) :: gribit,gribitua

contains

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

subroutine alloc_native_grid

implicit none

integer :: ct

if (trim(mtype) /= 'st4') then
  nvar2d=17
  if(.not. large_ngrid)then
      nvar3d=7 ! add 1 for tkesig if needed
      l_process_uv = .true.
      l_process_w = .true.
  else ! large_ngrid
      l_process_w = .false.
      if(.not. large_pgrid)then
        nvar3d=6
        l_process_uv = .true.
      else
        nvar3d=4
        l_process_uv = .false.
      endif
  endif
  if (make_micro) then
      nvar3d=nvar3d+5
      if(c_m2z == 'wrf') then
          nvar3d=nvar3d+1
      endif
  endif

  allocate(nlat(nx,ny),nlon(nx,ny))

  print*,'Native grid allocation 2d/3d/2dpts/3dpts = ',nvar2d,nvar3d,nx*ny*nvar2d,nx*ny*nz*nvar3d

  allocate(ngrid(nx,ny,nvar2d+nvar3d*nz))

  ngrid=rmsg

  ct=1

  nzsfc    =>ngrid(1:nx,1:ny,ct); ct=ct+1
  npsfc    =>ngrid(1:nx,1:ny,ct); ct=ct+1
  ntsfc    =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nmrsfc   =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nusfc    =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nvsfc    =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nwsfc    =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nground_t=>ngrid(1:nx,1:ny,ct); ct=ct+1
  npblhgt  =>ngrid(1:nx,1:ny,ct); ct=ct+1
  npcp_tot =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nlwout   =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nswout   =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nlwdown  =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nswdown  =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nshflux  =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nlhflux  =>ngrid(1:nx,1:ny,ct); ct=ct+1
  nsnowc   =>ngrid(1:nx,1:ny,ct); ct=ct+1

  npsig    =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz; l_process_p = .true.
  nzsig    =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz; l_process_z = .true.
  ntsig    =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz; l_process_t = .true.
  nmrsig   =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz; l_process_mr = .true.

  if(l_process_uv)then
      nusig    =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
      nvsig    =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
  endif

  if(l_process_w)then
      nwsig    =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
  endif

  if (make_micro) then
    k_micro = ct
    ncldliqmr_sig =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
    ncldicemr_sig =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
    nrainmr_sig   =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
    nsnowmr_sig   =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
    ngraupelmr_sig=>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
    if(c_m2z == 'wrf') then
       nrefl_sig  =>ngrid(1:nx,1:ny,ct:ct+nz-1); ct=ct+nz
    endif
  endif
else
  nvar2d=1
  nvar3d=0

  allocate(nlat(nx,ny),nlon(nx,ny))

  allocate(ngrid(nx,ny,nvar2d+nvar3d*nz))

  ngrid=rmsg

  ct=1

  npcp_tot =>ngrid(1:nx,1:ny,ct); ct=ct+1
endif

return
end subroutine

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

subroutine alloc_hinterp_grid

implicit none

integer :: ct

if(.not. large_ngrid)then ! state variables
   nvar3dh=7
else
   if(l_process_uv)then ! process U,V
      nvar3dh=6
   else
      nvar3dh=4
   endif
endif

if (make_micro) then
   nvar3dh=nvar3dh+8
endif

print*,'hinterp grid allocation 3d/3dpts = ',nvar3dh,lx*ly*nz*nvar3dh
print*,'ctmax (predicted) = ',nz*nvar3dh
print*,'nvar3dh / nvar3d = ',nvar3dh,nvar3d

allocate(hgrid(lx,ly,nvar3dh*nz))

hgrid=rmsg

ct=1

hpsig    =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz

hzsig    =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz

htsig    =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
hmrsig   =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz

if(l_process_uv)then
   husig    =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hvsig    =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
!  htkesig  =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
endif

if(l_process_w)then
   hwsig    =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
endif

if (make_micro) then
   hcldliqmr_sig =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hcldicemr_sig =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hrainmr_sig   =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hsnowmr_sig   =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hgraupelmr_sig=>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hrefl_sig     =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hzdr_sig     =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
   hldr_sig     =>hgrid(1:lx,1:ly,ct:ct+nz-1); ct=ct+nz
endif

print*,'ctmax (actual) = ',ct - 1
if(nz*nvar3dh .ne. ct-1)then
    write(6,*)' ERROR: ctmax actual is different from predicted'
    stop
endif

return
end subroutine

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

subroutine alloc_isobaric_grid

implicit none

integer :: ct

if(.not. large_pgrid)then ! state variables
   nvar3dout=7
else
   nvar3dout=0
endif

if (make_micro) then
   if(.not. large_pgrid)then
      nvar3dout=nvar3dout+9
   else
      nvar3dout=nvar3dout+1
   endif
endif

allocate(pgrid(lx,ly,nvar3dout*lz),name3d(nvar3dout*lz),units3d(nvar3dout*lz)  &
        ,lvltype3d(nvar3dout*lz),com3d(nvar3dout*lz),lvls3d(nvar3dout*lz))

if (out_grib) then
   allocate(gribitua(nvar3dout),paramua(nvar3dout),scalep10ua(nvar3dout))
endif

pgrid=rmsg

ct=1

if(.not. large_pgrid)then
   zprs  =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='HT '; com3d(ct:ct+lz-1)='Geopotential Height'       ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
!  rhprs =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='RH3'; com3d(ct:ct+lz-1)='Relative Humidity'         ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   tprs  =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='T3 '; com3d(ct:ct+lz-1)='Temperature'               ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   shprs =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='SH '; com3d(ct:ct+lz-1)='Specific Humidity'         ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   uprs  =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='U3 '; com3d(ct:ct+lz-1)='U-component Wind'          ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   vprs  =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='V3 '; com3d(ct:ct+lz-1)='V-component Wind'          ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
!  tkeprs=>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='TKE'; com3d(ct:ct+lz-1)='Turbulent Kinetic Energy'  ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   wprs  =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='W3 '; com3d(ct:ct+lz-1)='Vertical Velocity'         ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   omprs =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='OM '; com3d(ct:ct+lz-1)='Pressure Vertical Velocity'; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
endif

if (make_micro) then
   if(.not. large_pgrid)then
      cldliqmr_prs =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='LWC'; com3d(ct:ct+lz-1)='Cloud Liq.'     ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      cldicemr_prs =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='ICE'; com3d(ct:ct+lz-1)='Cloud Ice'      ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      rainmr_prs   =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='RAI'; com3d(ct:ct+lz-1)='Rain Conc.'     ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      snowmr_prs   =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='SNO'; com3d(ct:ct+lz-1)='Snow Conc.'     ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      graupelmr_prs=>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='PIC'; com3d(ct:ct+lz-1)='Graupel Conc.'  ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      refl_prs     =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='REF'; com3d(ct:ct+lz-1)='Radar Ref.'     ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      zdr_prs     =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='ZDR'; com3d(ct:ct+lz-1)='Radar ZDR'       ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      ldr_prs     =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='LDR'; com3d(ct:ct+lz-1)='Radar LDR'       ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
      pcptype_prs  =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='PTY'; com3d(ct:ct+lz-1)='Precip. Type'   ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   else ! allocate just reflectivity
      refl_prs     =>pgrid(1:lx,1:ly,ct:ct+lz-1); name3d(ct:ct+lz-1)='REF'; com3d(ct:ct+lz-1)='Radar Ref.'     ; lvls3d(ct:ct+lz-1)=nint(lprs); ct=ct+lz
   endif
endif

if (out_grib) then
   ct=1
   gribitua(ct)=.true.; paramua(ct)=7  ; scalep10(ct)=0 ; ct=ct+1  ! zprs
!  gribitua(ct)=.false.;                                ; ct=ct+1  ! rhprs
   gribitua(ct)=.true.; paramua(ct)=11 ; scalep10(ct)=2 ; ct=ct+1  ! tprs
   gribitua(ct)=.true.; paramua(ct)=51 ; scalep10(ct)=8 ; ct=ct+1  ! shprs
   gribitua(ct)=.true.; paramua(ct)=33 ; scalep10(ct)=1 ; ct=ct+1  ! uprs
   gribitua(ct)=.true.; paramua(ct)=34 ; scalep10(ct)=1 ; ct=ct+1  ! vprs
!   gribitua(ct)=.true.; paramua(ct)=158; scalep10(ct)=3 ; ct=ct+1  ! tkeprs
   gribitua(ct)=.true.; paramua(ct)=40 ; scalep10(ct)=3 ; ct=ct+1  ! wprs
   gribitua(ct)=.true.; paramua(ct)=39 ; scalep10(ct)=3 ; ct=ct+1  ! omprs
   if (make_micro) then
      gribitua(ct)=.true.; paramua(ct)=153; scalep10(ct)=6 ; ct=ct+1  ! cldliqmr_prs
      gribitua(ct)=.true.; paramua(ct)=178; scalep10(ct)=6 ; ct=ct+1  ! cldicemr_prs
      gribitua(ct)=.true.; paramua(ct)=170; scalep10(ct)=6 ; ct=ct+1  ! rainmr_prs
      gribitua(ct)=.true.; paramua(ct)=171; scalep10(ct)=6 ; ct=ct+1  ! snowmr_prs
      gribitua(ct)=.true.; paramua(ct)=179; scalep10(ct)=6 ; ct=ct+1  ! graupelmr_prs
      gribitua(ct)=.true.; paramua(ct)=128; scalep10(ct)=0 ; ct=ct+1  ! refl_prs
!      gribitua(ct)=.true.; paramua(ct)=128; scalep10(ct)=0 ; ct=ct+1  ! zdr_prs
!      gribitua(ct)=.true.; paramua(ct)=128; scalep10(ct)=0 ; ct=ct+1  ! ldr_prs
      gribitua(ct)=.true.; paramua(ct)=136; scalep10(ct)=0 ; ct=ct+1  ! pcptype_prs
   endif
endif

return
end subroutine

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

subroutine alloc_surface_grid

implicit none

integer :: ct

if (trim(mtype) /= 'st4') then
  nvar2dout=55
  if (make_micro) nvar2dout=nvar2dout+5
  if (make_firewx) nvar2dout=nvar2dout+7

  allocate(sgrid(lx,ly,nvar2dout),name2d(nvar2dout),units2d(nvar2dout)  &
        ,lvltype2d(nvar2dout),com2d(nvar2dout),lvls2d(nvar2dout))

  if (out_grib) then
     allocate(gribit(nvar2dout),param(nvar2dout),leveltype(nvar2dout)  &
           ,level1(nvar2dout),level2(nvar2dout),timerange(nvar2dout),scalep10(nvar2dout))
  endif

  sgrid=rmsg

  ct=1

! The order of the first set of variables needs to match the order of
!   the surface variables in the native grid.

  zsfc       =>sgrid(1:lx,1:ly,ct); name2d(ct)='TER'; com2d(ct)='Model Terrain'              ; ct=ct+1
  psfc       =>sgrid(1:lx,1:ly,ct); name2d(ct)='PSF'; com2d(ct)='Surface Pressure'           ; ct=ct+1
  tsfc       =>sgrid(1:lx,1:ly,ct); name2d(ct)='TSF'; com2d(ct)='Sfc Temperature'            ; ct=ct+1
  mrsfc      =>sgrid(1:lx,1:ly,ct); name2d(ct)='MSF'; com2d(ct)='Sfc Mixing Ratio'           ; ct=ct+1
  usfc       =>sgrid(1:lx,1:ly,ct); name2d(ct)='USF'; com2d(ct)='Sfc U-Component Wind'       ; ct=ct+1
  vsfc       =>sgrid(1:lx,1:ly,ct); name2d(ct)='VSF'; com2d(ct)='Sfc V-Component Wind'       ; ct=ct+1
  wsfc       =>sgrid(1:lx,1:ly,ct); name2d(ct)='WSF'; com2d(ct)='Sfc Vertical Velocity'      ; ct=ct+1
  ground_t   =>sgrid(1:lx,1:ly,ct); name2d(ct)='TGD'; com2d(ct)='Ground Temperature'         ; ct=ct+1
  pblhgt     =>sgrid(1:lx,1:ly,ct); name2d(ct)='BLH'; com2d(ct)='Boundary Layer Depth'       ; ct=ct+1
  pcp_tot    =>sgrid(1:lx,1:ly,ct); name2d(ct)='RTO'; com2d(ct)='Run-total Liq. Precip Accum'; ct=ct+1
  lwout      =>sgrid(1:lx,1:ly,ct); name2d(ct)='LWO'; com2d(ct)='Outgoing LW Radiation'      ; ct=ct+1
  swout      =>sgrid(1:lx,1:ly,ct); name2d(ct)='SWO'; com2d(ct)='Outgoing SW Radiation'      ; ct=ct+1
  lwdown     =>sgrid(1:lx,1:ly,ct); name2d(ct)='LWI'; com2d(ct)='Incoming LW Radiation'      ; ct=ct+1
  swdown     =>sgrid(1:lx,1:ly,ct); name2d(ct)='SWI'; com2d(ct)='Incoming SW Radiation'      ; ct=ct+1
  shflux     =>sgrid(1:lx,1:ly,ct); name2d(ct)='SHF'; com2d(ct)='Sensible Heat Flux'         ; ct=ct+1
  lhflux     =>sgrid(1:lx,1:ly,ct); name2d(ct)='LHF'; com2d(ct)='Latent Heat Flux'           ; ct=ct+1
  upflux     =>sgrid(1:lx,1:ly,ct); name2d(ct)='UMF'; com2d(ct)='Upslope Moisture Flux'      ; ct=ct+1
  bt11u      =>sgrid(1:lx,1:ly,ct); name2d(ct)='S8A'; com2d(ct)='11u Brightness Temperature' ; ct=ct+1
  simvis     =>sgrid(1:lx,1:ly,ct); name2d(ct)='SMV'; com2d(ct)='Albedo (Vis Satellite)'     ; ct=ct+1

  thetasfc   =>sgrid(1:lx,1:ly,ct); name2d(ct)='TH '; com2d(ct)='Sfc Potential Temperature'       ; ct=ct+1
  thetaesfc  =>sgrid(1:lx,1:ly,ct); name2d(ct)='THE'; com2d(ct)='Sfc Equiv. Potential Temperature'; ct=ct+1
  rhsfc      =>sgrid(1:lx,1:ly,ct); name2d(ct)='RH '; com2d(ct)='Sfc Relative Humidity'           ; ct=ct+1
  tdsfc      =>sgrid(1:lx,1:ly,ct); name2d(ct)='DSF'; com2d(ct)='Sfc Dewpoint Temperature'        ; ct=ct+1
  redp       =>sgrid(1:lx,1:ly,ct); name2d(ct)='P  '; com2d(ct)='Reduced Pressure'                ; ct=ct+1
  pmsl       =>sgrid(1:lx,1:ly,ct); name2d(ct)='SLP'; com2d(ct)='Sea-level Pressure'              ; ct=ct+1
  ztw0       =>sgrid(1:lx,1:ly,ct); name2d(ct)='TW0'; com2d(ct)='Height of wet-bulb = zero'       ; ct=ct+1
  ztw1       =>sgrid(1:lx,1:ly,ct); name2d(ct)='TW1'; com2d(ct)='Height of wet-bulb = 1.3'        ; ct=ct+1
  cldbase    =>sgrid(1:lx,1:ly,ct); name2d(ct)='LCB'; com2d(ct)='Cloud Base ASL'                  ; ct=ct+1
  cldtop     =>sgrid(1:lx,1:ly,ct); name2d(ct)='LCT'; com2d(ct)='Cloud Top ASL'                   ; ct=ct+1
  cldamt     =>sgrid(1:lx,1:ly,ct); name2d(ct)='LCV'; com2d(ct)='Cloud Opacity'                   ; ct=ct+1
  cldalb     =>sgrid(1:lx,1:ly,ct); name2d(ct)='CLA'; com2d(ct)='Cloud Albedo'                    ; ct=ct+1
  ceiling    =>sgrid(1:lx,1:ly,ct); name2d(ct)='CCE'; com2d(ct)='Cloud Ceiling AGL'               ; ct=ct+1
  intliqwater=>sgrid(1:lx,1:ly,ct); name2d(ct)='LIL'; com2d(ct)='Integrated Cloud Liquid'         ; ct=ct+1
  intcldice  =>sgrid(1:lx,1:ly,ct); name2d(ct)='LIC'; com2d(ct)='Integrated Cloud Ice'            ; ct=ct+1
! intgraupel =>sgrid(1:lx,1:ly,ct); name2d(ct)='LIG'; com2d(ct)='Integrated Graupel'              ; ct=ct+1
  totpcpwater=>sgrid(1:lx,1:ly,ct); name2d(ct)='TPW'; com2d(ct)='Total Precipitable Water'        ; ct=ct+1
  max_refl   =>sgrid(1:lx,1:ly,ct); name2d(ct)='LMR'; com2d(ct)='Composite Reflectivity'          ; ct=ct+1
  echo_tops  =>sgrid(1:lx,1:ly,ct); name2d(ct)='LMT'; com2d(ct)='Radar Echo Tops'                 ; ct=ct+1
  refl_sfc   =>sgrid(1:lx,1:ly,ct); name2d(ct)='LLR'; com2d(ct)='1km AGL Reflectivity'            ; ct=ct+1
  pcptype_sfc=>sgrid(1:lx,1:ly,ct); name2d(ct)='SPT'; com2d(ct)='Sfc Precip. Type'                ; ct=ct+1
  pcp_inc    =>sgrid(1:lx,1:ly,ct); name2d(ct)='R01'; com2d(ct)='Incremental Tot. Liq. Precip'    ; ct=ct+1
  snow_inc   =>sgrid(1:lx,1:ly,ct); name2d(ct)='S01'; com2d(ct)='Incremental Snow Depth'          ; ct=ct+1
  snow_tot   =>sgrid(1:lx,1:ly,ct); name2d(ct)='STO'; com2d(ct)='Run-total Snow Accum'            ; ct=ct+1
  snow_cvr   =>sgrid(1:lx,1:ly,ct); name2d(ct)='SC' ; com2d(ct)='Snow Cover Fraction'             ; ct=ct+1
  srhel      =>sgrid(1:lx,1:ly,ct); name2d(ct)='LHE'; com2d(ct)='Storm Relative Helicity'         ; ct=ct+1
  uhel       =>sgrid(1:lx,1:ly,ct); name2d(ct)='UHE'; com2d(ct)='Updraft Helicity'                ; ct=ct+1
  cape       =>sgrid(1:lx,1:ly,ct); name2d(ct)='PBE'; com2d(ct)='CAPE'                            ; ct=ct+1
  cin        =>sgrid(1:lx,1:ly,ct); name2d(ct)='NBE'; com2d(ct)='CIN'                             ; ct=ct+1
  bshr       =>sgrid(1:lx,1:ly,ct); name2d(ct)='BSH'; com2d(ct)='Bulk Shear'                      ; ct=ct+1
  scp        =>sgrid(1:lx,1:ly,ct); name2d(ct)='SCP'; com2d(ct)='Supercell Composite Parameter'   ; ct=ct+1
  liftedind  =>sgrid(1:lx,1:ly,ct); name2d(ct)='LI '; com2d(ct)='Lifted Index'                    ; ct=ct+1
  visibility =>sgrid(1:lx,1:ly,ct); name2d(ct)='VIS'; com2d(ct)='Sfc. Visibility'                 ; ct=ct+1
  heatind    =>sgrid(1:lx,1:ly,ct); name2d(ct)='HI '; com2d(ct)='Heat Index'                      ; ct=ct+1
  u80        =>sgrid(1:lx,1:ly,ct); name2d(ct)='U80'; com2d(ct)='U-component Wind at 80m'         ; ct=ct+1
  v80        =>sgrid(1:lx,1:ly,ct); name2d(ct)='V80'; com2d(ct)='V-component Wind at 80m'         ; ct=ct+1

  if (make_micro) then
     clwmrsfc  =>sgrid(1:lx,1:ly,ct); name2d(ct)='SCL'; com2d(ct)='Sfc Cloud Liq Water MR'; ct=ct+1
     icemrsfc  =>sgrid(1:lx,1:ly,ct); name2d(ct)='SIC'; com2d(ct)='Sfc Cloud Ice MR'      ; ct=ct+1
     snowmrsfc =>sgrid(1:lx,1:ly,ct); name2d(ct)='SSN'; com2d(ct)='Sfc Prec. Snow MR'     ; ct=ct+1
     rainmrsfc =>sgrid(1:lx,1:ly,ct); name2d(ct)='SRN'; com2d(ct)='Sfc Prec. Rain MR'     ; ct=ct+1
     graupmrsfc=>sgrid(1:lx,1:ly,ct); name2d(ct)='SGR'; com2d(ct)='Sfc Prec. Graupel MR'  ; ct=ct+1
  endif

  if (make_firewx) then
     upbl     =>sgrid(1:lx,1:ly,ct); name2d(ct)='UPB'; com2d(ct)='U-component Wind in PBL'; ct=ct+1
     vpbl     =>sgrid(1:lx,1:ly,ct); name2d(ct)='VPB'; com2d(ct)='V-component Wind in PBL'; ct=ct+1
     vnt_index=>sgrid(1:lx,1:ly,ct); name2d(ct)='VNT'; com2d(ct)='Ventilation Index'      ; ct=ct+1
     ham_index=>sgrid(1:lx,1:ly,ct); name2d(ct)='HAM'; com2d(ct)='Mid-Level Haines Index' ; ct=ct+1
     hah_index=>sgrid(1:lx,1:ly,ct); name2d(ct)='HAH'; com2d(ct)='High-Level Haines Index'; ct=ct+1
     fwi_index=>sgrid(1:lx,1:ly,ct); name2d(ct)='FWI'; com2d(ct)='Fosberg Fire Wx Index'  ; ct=ct+1
     fwx_index=>sgrid(1:lx,1:ly,ct); name2d(ct)='FWX'; com2d(ct)='LAPS/Kelsch Fire Wx Index'  ; ct=ct+1
  endif

  if (out_grib) then
     ct=1
     gribit(ct)=.true.; param(ct)=7  ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! zsfc
     gribit(ct)=.true.; param(ct)=1  ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! psfc
     gribit(ct)=.true.; param(ct)=11 ; leveltype(ct)=105; level1(ct)=2 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! tsfc
     gribit(ct)=.false.                                                                                ; ct=ct+1  ! mrsfc
     gribit(ct)=.true.; param(ct)=33 ; leveltype(ct)=105; level1(ct)=10; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! usfc
     gribit(ct)=.true.; param(ct)=34 ; leveltype(ct)=105; level1(ct)=10; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! vsfc
     gribit(ct)=.true.; param(ct)=40 ; leveltype(ct)=105; level1(ct)=10; level2(ct)=0; timerange(ct)=0; scalep10(ct)=4 ; ct=ct+1  ! wsfc
     gribit(ct)=.true.; param(ct)=11 ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! ground_t
     gribit(ct)=.true.; param(ct)=221; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! pblhgt
     gribit(ct)=.true.; param(ct)=142; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=4; scalep10(ct)=1 ; ct=ct+1  ! pcp_tot
     gribit(ct)=.true.; param(ct)=212; leveltype(ct)=8  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! lwout
     gribit(ct)=.true.; param(ct)=211; leveltype(ct)=8  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! swout
     gribit(ct)=.true.; param(ct)=112; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! lwdown
     gribit(ct)=.true.; param(ct)=111; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! swdown
     gribit(ct)=.true.; param(ct)=122; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! shflux
     gribit(ct)=.true.; param(ct)=121; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! lhflux
!     gribit(ct)=.true.; param(ct)=121; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! upflux

     gribit(ct)=.true.; param(ct)=13 ; leveltype(ct)=105; level1(ct)=2 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! thetasfc
     gribit(ct)=.true.; param(ct)=14 ; leveltype(ct)=105; level1(ct)=2 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! thetaesfc
     gribit(ct)=.true.; param(ct)=52 ; leveltype(ct)=105; level1(ct)=2 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! rhsfc
     gribit(ct)=.true.; param(ct)=17 ; leveltype(ct)=105; level1(ct)=2 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! tdsfc
     gribit(ct)=.false.                                                                                ; ct=ct+1  ! redp
     gribit(ct)=.true.; param(ct)=2  ; leveltype(ct)=102; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! pmsl
     gribit(ct)=.false.                                                                                ; ct=ct+1  ! ztw0
     gribit(ct)=.false.                                                                                ; ct=ct+1  ! ztw1
     gribit(ct)=.true.; param(ct)=138; leveltype(ct)=102; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! cldbase
     gribit(ct)=.true.; param(ct)=139; leveltype(ct)=102; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! cldtop
     gribit(ct)=.true.; param(ct)=71 ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! cldamt
     gribit(ct)=.true.; param(ct)=137; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! ceiling
     gribit(ct)=.false.                                                                                ; ct=ct+1  ! intliqwater
     gribit(ct)=.true.; param(ct)=54 ; leveltype(ct)=200; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! totpcpwater
     gribit(ct)=.true.; param(ct)=129; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! max_refl
     gribit(ct)=.true.; param(ct)=130; leveltype(ct)=102; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! echo_tops
     gribit(ct)=.true.; param(ct)=128; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! refl_sfc
     gribit(ct)=.true.; param(ct)=136; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! pcptype_sfc
     gribit(ct)=.true.; param(ct)=61 ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=4; scalep10(ct)=1 ; ct=ct+1  ! pcp_inc
     gribit(ct)=.true.; param(ct)=66 ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=4; scalep10(ct)=4 ; ct=ct+1  ! snow_inc
     gribit(ct)=.true.; param(ct)=141; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=4; scalep10(ct)=4 ; ct=ct+1  ! snow_tot
     gribit(ct)=.true.; param(ct)=190; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! srhel
     gribit(ct)=.true.; param(ct)=157; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! cape
     gribit(ct)=.true.; param(ct)=156; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=0 ; ct=ct+1  ! cin
     gribit(ct)=.true.; param(ct)=131; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=1 ; ct=ct+1  ! liftedind
     gribit(ct)=.true.; param(ct)=20 ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=-3; ct=ct+1  ! visibility
     gribit(ct)=.false.                                                                                ; ct=ct+1  ! heatind

     if (make_micro) then
        gribit(ct)=.true.; param(ct)=153; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=4; ct=ct+1  ! clwmrsfc
        gribit(ct)=.true.; param(ct)=178; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=4; ct=ct+1  ! icemrsfc
        gribit(ct)=.true.; param(ct)=171; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=4; ct=ct+1  ! snowmrsfc
        gribit(ct)=.true.; param(ct)=170; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=4; ct=ct+1  ! rainmrsfc
        gribit(ct)=.true.; param(ct)=179; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=0; scalep10(ct)=4; ct=ct+1  ! graupmrsfc
     endif

     if (make_firewx) then
        gribit(ct)=.false.                                                                                ; ct=ct+1  ! upbl
        gribit(ct)=.false.                                                                                ; ct=ct+1  ! vpbl
        gribit(ct)=.false.                                                                                ; ct=ct+1  ! vnt_index
        gribit(ct)=.false.                                                                                ; ct=ct+1  ! ham_index
        gribit(ct)=.false.                                                                                ; ct=ct+1  ! hah_index
        gribit(ct)=.false.                                                                                ; ct=ct+1  ! fwi_index
        gribit(ct)=.false.                                                                                ; ct=ct+1  ! fwx_index
     endif
  endif
else
  nvar2dout=1

  allocate(sgrid(lx,ly,nvar2dout),name2d(nvar2dout),units2d(nvar2dout)  &
        ,lvltype2d(nvar2dout),com2d(nvar2dout),lvls2d(nvar2dout))

  if (out_grib) then
     allocate(gribit(nvar2dout),param(nvar2dout),leveltype(nvar2dout)  &
           ,level1(nvar2dout),level2(nvar2dout),timerange(nvar2dout),scalep10(nvar2dout))
  endif

  sgrid=rmsg

  ct=1
  pcp_inc    =>sgrid(1:lx,1:ly,ct); name2d(ct)='R01'; com2d(ct)='Incremental Tot. Liq. Precip'    ; ct=ct+1
  if (out_grib) then
   ct=1
   gribit(ct)=.true.; param(ct)=61 ; leveltype(ct)=1  ; level1(ct)=0 ; level2(ct)=0; timerange(ct)=4; scalep10(ct)=1 ; ct=ct+1  ! pcp_inc
  endif
endif

return
end subroutine

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

subroutine dealloc_grid(gtype)

implicit none

character(len=*) :: gtype

select case(trim(gtype))
   case('native')
      deallocate(ngrid,nlat,nlon)
   case('horiz')
      deallocate(hgrid)
   case('isobaric')
      deallocate(pgrid,lprs,lprsl,name3d,units3d,lvltype3d,com3d,lvls3d)
   case('surface')
      deallocate(sgrid,llat,llon,name2d,units2d,lvltype2d,com2d,lvls2d)
      if (out_grib) deallocate(gribit,param,leveltype  &
                              ,level1,level2,timerange,scalep10)
end select

return
end subroutine

end module


program huckster
  use integrals
  use constants
  use hamiltonians
  use density
  use crits
  use log
  implicit none

  ! homo lumo
  character(len=4)::homolumo(3)=(/ '    ', 'HOMO', 'LUMO'/)
  integer :: hl_index
  integer :: HOMO
  integer :: LUMO

  ! Command line arguments
  character(len=150)           :: arg
  integer ::  charge
  character(len=150)::input_file, output_file
  character(len=:), allocatable :: output_name
  integer :: info

  integer, parameter :: calc_huckel=1, calc_promolecule=2
  integer :: calc_type
  logical :: do_crit, do_graph

  ! Integrals
  type(ElectronicSystem) :: electrons
  type(UnrolledMOs) :: umos

  ! Work parameters
  character(len=2) :: atomchar
  integer :: i, ii, j, naos, remaining_electrons

  ! Hamiltonian / overlap
  double precision, allocatable :: S_prim(:,:)
  double precision, allocatable :: H(:,:)
  double precision, allocatable :: S(:,:)
  double precision, allocatable :: MO(:,:)
  double precision, allocatable :: MO_AO(:,:)
  double precision, allocatable :: E_MO(:)
  double precision, allocatable :: occ(:)

  ! wfn output
  integer,parameter :: iwfn = 10
  integer,parameter :: icrit = 11

  ! CP output
  type(CritPoint), allocatable :: CPs(:)
  integer :: ncp
  integer, allocatable :: adjacency(:,:)
  integer :: ifile

  ! Load command line arguments
  charge = 0
  i = 1
  calc_type = calc_huckel
  do_crit = .false.
  do_graph = .false.
  verbosity = 0
  do while (i .le. command_argument_count())
     call get_command_argument(i, arg)
     select case (arg)

     case ('--')
        ! prepping to receive final argument
        exit

     case ('-h', '--help')
        call print_help()
        stop 0

     case ('-q', '--quiet')
        verbosity = -1

     case ('-v', '--verbose')
        verbosity = 1

     case ('-vv', '--very-verbose')
        verbosity = 2

     case ('-a', '--aim')
        do_crit = .true.

     case ('-g', '--graph')
        do_crit = .true.        ! we need CPs for the graph
        do_graph = .true.

     case ('-t', '--type')
        call get_command_argument(i+1,arg)

        select case(arg)
        case('pro', 'promolecule', 'sad')
           calc_type = calc_promolecule

        case('huckel','eht')
           calc_type = calc_huckel

        case default
           call log_err('huckster', trim(arg) // ' is not a valid calculation type')
           error stop -1
        end select
        i = i + 1

     case ('-c', '--charge')
        call get_command_argument(i+1,arg)
        read(arg, *, iostat=info) charge
        if (info .ne. 0) then
           call log_err('huckster', trim(arg) // ' is an invalid charge.')
           error stop -1
        else
           i = i + 1
        end if

     case default
        call log_err('huckster', 'unrecognized command-line option ' // trim(arg))
     end select
     i = i + 1
  end do

  ! print out the program banner
  call log_banner

  if ((i .eq. command_argument_count()) .or. (command_argument_count() .eq. 0)) then
     call log_err('huckster', 'no geometry file passed')
     error stop -1
  else
     i = i + 1
     call get_command_argument(i, input_file)

     if (i < command_argument_count()) then
        call get_command_argument(i+1, output_file)
     else
        output_file = input_file
     end if
  end if

  ! remove extension
  associate (idot => index(output_file, '.', back=.true.))
    if (idot > 0) then
       output_name = output_file(1:idot-1)
    else
       output_name = output_file(1:len_trim(output_file))
    end if
  end associate

  ! ---------------------------------------------------------------------------------
  ! Initialize integral module
  call integrals_initialize

  ! ---------------------------------------------------------------------------------
  ! Read input geometry
  call log_program_step('Reading geometry file')
  if (verbosity.ge.0) write(*,*) '     file: ',input_file

  open(unit=2, file=input_file, action='READ', iostat=info)
  if (info .ne. 0) then
     call log_err('huckster', 'could not open input geometry file: ' // input_file)
     error stop -1
  end if
  call integrals_init_from_file(2, electrons, charge)
  close(unit=2)
  call log_program_step_end

  ! ---------------------------------------------------------------------------------
  ! Generate the basis
  call log_program_step('Loading primitive basis')
  call integrals_build_basis(electrons)
  call log_program_step_end

  call log_program_step('Loading AO coeffs and energies')
  call integrals_build_atomic_orbitals(electrons)
  naos = electrons%naos
  call log_program_step_end

  if (calc_type .eq. calc_huckel) then
     ! ---------------------------------------------------------------------------------
     ! Setup the Hamiltonian
     call log_program_step('Building Extended Huckel Hamiltonian')

     call log_program_substep('generating overlaps in the gaussian basis')
     call integrals_overlaps(electrons, S_prim)

     call log_program_substep('projecting S_orb to opt. AOs')
     call integrals_symm_bas2ao(electrons, S_prim, S)

     call log_program_substep('generating Hamiltonian elements')
     allocate(H(naos,naos))
     do i = 1, naos
        H(i,i) = electrons%E_AO(i)
        do j =i+1, naos
           ! multiply off diag by Ei + Ej / 2
           H(i,j) = S(i,j) * (electrons%E_AO(i) + electrons%E_AO(j)) * 0.5 * K_PARAMETER
        end do
     end do
     call log_program_step_end

     call log_program_step('Eigendecomposition of H')
     if (verbosity .ge. 0) write(*,'(a,i5,a,i5)') '      H has dimension', naos, ' x ', naos

     call log_program_substep('diagonalizing')
     call hamiltonians_diag_on_basis(H, S, E_MO, MO_AO)

     call log_program_substep('projecting to the primitive basis')
     call integrals_MO_AO_transform(electrons, MO_AO, MO)

     call log_program_substep('projecting to the primitive basis')
     call integrals_MO_AO_transform(electrons, MO_AO, MO)
     call log_program_step_end

     if (verbosity > 0) then
        write(*,*) '     +------------------------'
        write(*,*) '     MO |  Energy  |  occ'
     end if

     ! todo move that somewhere else
     ! setup occupation
     allocate(occ(naos))
     remaining_electrons = electrons%nelec

     hl_index = 1
     do ii=1,naos
        if (remaining_electrons > 0) then
           occ(ii) = dble(min(2, remaining_electrons))
           remaining_electrons = remaining_electrons - min(2, remaining_electrons)
           if (remaining_electrons .eq. 0) then
              hl_index = 2
              HOMO = ii
           end if
        else
           select case (hl_index)
           case(3)
              hl_index = 1
           case (2)
              hl_index = 3
              LUMO = ii
           case default
           end select
           occ(ii) = 0d0
        end if

        if (verbosity > 0) then
           write(*, '(a, i4,a,f9.4,a,f3.1, 2a)')      '    ',ii, ' | ', E_MO(ii),&
                '|  ', occ(ii),'  ', homolumo(hl_index)
        end if
     end do
     if (verbosity .ge. 0) then
        write(*,*) '     +------------------------'
        write(*,'(a,f9.4,a)') '      Δ HOMO-LUMO = ', E_MO(LUMO) - E_MO(HOMO), ' Hartrees'
        write(*,'(a,f9.4,a)') '                    ', (E_MO(LUMO) - E_MO(HOMO)) * conv_ev, ' eV'
        write(*,*) ''
     end if

  elseif (calc_type .eq. calc_promolecule) then
     call log_program_step('Generating promolecule electron density')
     if (charge .ne. 0) then
        call log_err('huckster', 'promolecule density is not compatible with charged species.')
        error stop 1
     end if
     occ = electrons%pop_ao
     MO = electrons%C_AO
     allocate(E_MO(naos))
     E_MO(:) = 0.0
     call log_program_step_end
  end if

  call log_program_step('Saving wavefunction')
  open(iwfn, file=output_name // '.wfn', action='write', iostat=info)

  if (info .ne. 0) then
     call log_err('huckster', 'Could not open output wfn file')
     error stop -1
  end if

  ! Put the MOs into the fully unrolled, uncontracted primitive form that goes
  ! into AIM file and related routines.
  call log_program_substep('unrolling MOs to primitive functions')
  call integrals_unroll(electrons, MO, umos)

  call log_program_substep('writing to file: ' // output_name // '.wfn')
  call integrals_write_to_wfn(iwfn, umos, E_MO, occ)
  close(iwfn)

  call log_program_step_end

  if (do_crit) then
     call log_program_step('Finding critical points')
     ! initialize density evaluator
     call density_initialize(umos, occ)
     call crits_initialize(umos)

     call crits_do_grid
     call crits_print
     ! todo: if some are missing, maybe try do_bonds etc.
     call crits_get_CPs(CPs, ncp)
     if (verbosity .ge. 0) write(*,*) '         writing CPs to csv file'

     open(unit=ifile, file= output_name // '.csv')
     write(ifile, *) 'index,atom,rank,curv,x,y,z,rho,ellip_x,ellip_y,ellip_z'
     do i=1, ncp
        write(ifile,'(i4,a)', advance='no') i, ','
        if (CPs(i)%atom_id > 0) then
           write(ifile,'(a,a)', advance='no') umos%atoms(CPs(i)%atom_id), ','
        else
           write(ifile,'(a)', advance='no') ','
        end if
        write(ifile,'(i2,a)', advance='no') CPs(i)%rank, ','
        write(ifile,'(i2,a)', advance='no') CPs(i)%curvature, ','
        write(ifile,'(E23.15,a)', advance='no') CPs(i)%position(1), ','
        write(ifile,'(E23.15,a)', advance='no') CPs(i)%position(2), ','
        write(ifile,'(E23.15,a)', advance='no') CPs(i)%position(3), ','
        write(ifile,'(E23.15,a)', advance='no') CPs(i)%electron_density, ','
        write(ifile,'(E23.15,a)', advance='no') CPs(i)%ellipticity(1), ','
        write(ifile,'(E23.15,a)', advance='no') CPs(i)%ellipticity(2), ','
        write(ifile,'(E23.15)', advance='no') CPs(i)%ellipticity(3)
        write(ifile,*) ''
     end do
     close(unit=ifile)

     call log_program_step_end
  end if

  if (do_graph) then
     call log_program_step('Connecting critical points into graph')
     neval = 0
     call crits_perceive_graph(adjacency)
     call log_program_step_end
     if (verbosity .ge. 0) write(*,*) '         writing adjacency matrix to .mat file'

     open(unit=ifile, file=output_name // '.mat')
     do i=1, ncp
        do j=1,ncp
           write(ifile,'(i2)',advance='no') adjacency(j, i)
        end do
        write(ifile,*) ''
     end do
     close(unit=ifile)
     write(*,*) ''
  end if

  if (verbosity .ge. 0) write(*,*) '~~~~~END~~~~END~~~~END~~~~END~~~~END~~~~END~~~~END~~~~~~'

  stop 0
contains
  subroutine print_help
    write(*,*) 'USAGE: huckster [options] -- GEOMETRY [OUTPUT]'
    write(*,*) ''
    write(*,*) 'Huckster is a standalone program to perform extended Huckel theory calculations,'
    write(*,*) 'specifically to use in QTAIM calculations. It takes a single mandatory argument,'
    write(*,*) 'a molecular geometry in the XMOL format in file GEOMETRY and outputs a AIM-format'
    write(*,*) 'wavefunction file to OUTPUT (defaults to GEOMETRY with a .wfn extension).'

    write(*,*) 'Command-line options'
    write(*,*) '   -c, --charge CHRG          Set the global charge of the computed molecule.'
    write(*,*) '   -t, --type TYPE            Define computation type (TYPE = {eht, pro}.)'
    write(*,*) '   -a, --aim                  Do a QTAIM search for critical points.'
    write(*,*) '   -g, --graph                Build molecular graph from QTAIM analysis.'
    write(*,*) ''

    write(*,*) '   -h, --help                 Print these instructions.'
    write(*,*) '   -v, --verbose              Print more information.'
    write(*,*) '   -vv, --very-verbose        Print more information.'
    write(*,*) '   -q, --quiet                Silence output'

  end subroutine print_help

end program huckster


      subroutine params
c******************************************************************************
c     This subroutine reads in the commands from the parameter file
c******************************************************************************

      implicit real*8 (a-h,o-z)
      include 'Atmos.com'
      include 'Linex.com'
      include 'Factor.com'
      include 'Pstuff.com'
      include 'Obspars.com'
      include 'Mol.com'
      include 'Multistar.com'
      real*8 deltalogab(5)
      character keyword*20
      character arrayz*80
      integer kk
      data newcount, linecount /0, 0/

      if (linecount .eq. 0) oldcount = 0

c  IF DOING MULTIPLE RUNS: if this is not the first reading of the
c  parameter file, then read down to correct place in parameter file,
c  using "linecount", and then skip the re-initialization of the
c  various variables
      rewind nfparam
      read (nfparam,1001,end=100) arrayz
      if (linecount .ne. 0) then
         do i=1,linecount
            read (nfparam,1001,end=100) arrayz
         enddo
         go to 4
      endif

c  INITIALIZE SOME VARIABLES: output file names and output file numbers
c  f1out, nf1out:    verbose standard output
c  f2out, nf2out:    raw synthetic spectra, or summary abundances, or
c                    summary curves-of-growth
c  f3out, nf3out:    smoothed synthetic spectra
c  f4out, nf4out:    IRAF-text-style synthetic spectra output
c  f5out, nf5out:    postscript plot output
c  f6out, nf6out:    synthetic/observed comparison text output (gridsyn)
c  f7out, nf7out:    raw synthetic spectrum of primary of a binary,
c                    output summary run table, or
c                    to be used for some other purpose as needed; at
c                    present not given keyword input
c  f8out, nf8out:    raw synthetic spectrum of secondary of a binary,
c                    or the kept lines in a line weedout, or for
c                    some other purpose as needed
c  f9out, nf9out:    combined smoothed synthetic spectrum of a binary star,
c                    or the discarded lines in a line weedout, or the
c                    mean raw synthesis for a population of stars, or
c                    some other purpose as needed
c                    to be used for some other purpose as needed`
c  f10out, nf10out:  combined smoothed synthetic spectrum of a binary star,
c                    to be used for some other purpose as needed`
      f1out =   'no_filename_given'
      f2out =   'no_filename_given'
      f3out =   'no_filename_given'
      f4out =   'no_filename_given'
      f5out =   'optional_output_file'
      f6out =   'optional_output_file'
      f7out =   'no_filename_given'
      f8out =   'no_filename_given'
      f9out =   'no_filename_given'
      f10out =  'no_filename_given'
      nf1out =   0
      nf2out =   0
      nf3out =   0
      nf4out =   0
      nf5out =   0
      nf6out =   0
      nf7out =   0
      nf8out =   0
      nf9out =   0
      nf10out =  0
      modelnum = 0

c  INITIALIZE SOME VARIABLES: input file names and input file numbers
      fmodel =  'no_filename_given'
      flines =  'no_filename_given'
      fslines = 'no_filename_given'
      fobs =    'no_filename_given'
      ftable =  'no_filename_given'
      nfmodel =  0
      nflines =  0
      nfslines = 0
      nfobs =    0
      nftable =  0

c  INITIALIZE SOME VARIABLES: terminal type;
c  set smterm = ' ' for the plotting package 'sm'
      smterm = 'x11'

c  INITIALIZE SOME VARIABLES:
c  atmosphere data printing:              modprintopt  [old ipr(1)]
c  molecular equilibrium:                 molopt       [old ipr(2)]
c  line data:                             linprintopt  [old ipr(3)]
c  flux/intensity                         fluxintopt   [old ipr(4)]
c  synthesis/single line computations:    [deleted]    [old ipr(5)]
c  line formation level                   [deleted]    [old ipr(6)]
c  plotting:                              plotopt      [old ipr(7)]
c  damping                                dampingopt   [old ipr(8)]
c  observed spectrum file type            specfileopt  [old ipr(9)]
c  format of linelist (formatted/not)     linfileopt
c  source function with scat+abs          scatopt
      modprintopt  = 1
      molopt       = 1
      linprintopt  = 1
      fluxintopt   = 0
      plotopt      = 0
      dampingopt   = 0
      specfileopt  = 0
      linfileopt   = 0
      iunits       = 0
      itru         = 0
      iscale       = 0
      nlines       = 0
      iraf         = 0
      histoyes     = 0
      byteswap     = 0
      deviations   = 0
      scatopt      = 0
      gfstyle      = 0
      maxshift     = 0
      dostrong     = 0
      molset       = 0

c  INITIALIZE SOME VARIABLES:
c   if fudge is less than or equal to 0 then it does not scale it...make it
c   -1.0 just to be sure we dont have floating point problems with 0.0
      fudge = -1.0

c  INITIALIZE SOME VARIABLES: spectrum run parameters
      oldstart = 0.
      start = 0.
      sstop = 0.
      step = 0.
      delta = 0.
      cogatom = 0.
      contnorm = 1.0

c  INITIALIZE SOME VARIABLES: line limit parameters
      ncurve = 0
      lim1line = 0
      lim2line = 0
      lim1obs = 0
      lim2obs = 0
      lim1 = 0
      lim2 = 0

c  INITIALIZE SOME VARIABLES: spectroscopic binary parameters
      deltaradvel = 0.
      lumratio = 1.

c  INITIALIZE SOME VARIABLES: elements with special abundance data; for
c  practical reasons, keyword "abundances" and "isotopes" must be specified
c  in each RUN; they must be reset each time.
4     neq = 0
      numpecatom = 0
      numatomsyn = 0
      newnumpecatom = 0
      newnumatomsyn = 0
      ninetynineflag = 0
      do i=1,95
         pec(i) = 0
         newpec(i) = 0
         do j=1,5
            abfactor(j) = 0.
            pecabund(i,j) = 0.
            newpecabund(i,j) = 0.
         enddo
      enddo
      numiso = 0
      numisosyn = 0
      newnumiso = 0
      newnumisosyn = 0
      do i=1,200
         isotope(i) = 0.
         newisotope(i) = 0.
         do j=1,5
            isoabund(i,j) = 0.
            newisoabund(i,j) = 0.
         enddo
      enddo

c  read a line of the parameter file into "arrayz"; decode it to get the
c  key word, which is always within the first 20 characters;  dump the
c  rest of arrayz into "array"
5     write (array,1007)
      read (nfparam,1001,end=98) arrayz
      linecount = linecount + 1
      i=index(arrayz,' ')
      keyword = arrayz(1:i-1)
      array = arrayz(i:)

c  keyword 'RUN' signals that there are either multiple syntheses being
c  done or multiple comparisons with observed spectra
      if (keyword .eq. 'RUN') then
         read (array,*) newcount
         if (newcount .gt. oldcount+1) then
            linecount = linecount - 1
            oldcount = syncount
            go to 100
         else
            syncount = newcount
            go to 5
         endif
      endif

c  keyword 'freeform' indicates whether or not the linelist will be read
c  in under format control (7e10.3) or will be free-form.  If freeform = 0,
c  the default value, then the old-style formatted input will be used;
c  If freeform = 1, unformatted read will be used, BUT the user must then
c  give values for all quantities (that is, explicit zeros will need to
c  be put instead of blank spaces.
      if     (keyword .eq. 'freeform') then
         read (array,*) linfileopt

c  keyword 'standard_out' controls the name of the verbose standard output
      elseif (keyword .eq. 'standard_out') then
         read (array,*) f1out

c  keyword 'summary_out' controls the name of either the EW summary or
c  the raw synthesis output
      elseif (keyword .eq. 'summary_out') then
         read (array,*) f2out

c  keyword 'hardpost_out' controls the name of a postscript plot output
      elseif (keyword .eq. 'hardpost_out') then
         read (array,*) f5out

c  keyword 'speccomp_out' controls the name of a text file containing the
c  comparisons (wavelength shifts, sigmas, etc.) between observed and
c  synthetic spectra
      elseif (keyword .eq. 'speccomp_out') then
         read (array,*) f6out

c  keyword 'bin_raw_out' controls the name of a file containing the
c  raw synthesis of a spectroscopic binary, with an appropriate velocity
c  difference and luminosity ratio dialed in
      elseif (keyword .eq. 'bin_raw_out') then
         read (array,*) f9out

c  keyword 'bin_smo_out' controls the name of a file containing the
c  smoothed synthesis of a spectroscopic binary
      elseif (keyword .eq. 'bin_smo_out') then
         read (array,*) f10out

c  keyword 'summary_in' controls the name of the raw synthesis file,
c  created previously, that will be read in for plotting purposes
      elseif (keyword .eq. 'summary_in') then
         read (array,*) f2out

c  keyword 'smoothed_out' controls the name of the smoothed synthesis output
      elseif (keyword .eq. 'smoothed_out') then
         read (array,*) f3out

c  keyword 'keeplines_out' controls the name of the list of kept lines
c  for future synthetic spectrum runs
      elseif (keyword .eq. 'keeplines_out') then
         read (array,*) f8out

c  keyword 'tosslines_out' controls the name of the list of discarded lines
c  that are too weak to keep in future synthetic spectrum runs
      elseif (keyword .eq. 'tosslines_out') then
         read (array,*) f9out

c  keyword 'iraf_out' controls the name of the optional IRAF output
      elseif (keyword .eq. 'iraf_out') then
         read (array,*) f4out

c  keyword 'model_in' controls the name of input model atmosphere file
      elseif (keyword .eq. 'model_in') then
         read (array,*) fmodel

c  keyword 'lines_in' controls the name of the input line list
      elseif (keyword .eq. 'lines_in') then
         read (array,*) flines

c  keyword 'stronglines_in' controls the name of the input strong line list
      elseif (keyword .eq. 'stronglines_in') then
         read (array,*) fslines

c  keyword 'observed_in' controls the name of the input observed spectrum
      elseif (keyword .eq. 'observed_in') then
         read (array,*) fobs

c  keyword 'table_in' controls the name of the extra input instruction file
      elseif (keyword .eq. 'table_in   ') then
         read (array,*) ftable

c  keyword 'table_out' controls the name of the extra input instruction file
      elseif (keyword .eq. 'table_out  ') then
         read (array,*) f7out

c  keyword 'popsyn_out' controls the name of the extra input instruction file
      elseif (keyword .eq. 'popsyn_out ') then
         read (array,*) f9out

c  keyword 'rawbin_out ' controls the name of the input observed spectrum
      elseif (keyword .eq. 'rawbin_out ') then
         read (array,*) f9out

c  keyword 'smoobin_out' controls the name of the input observed spectrum
      elseif (keyword .eq. 'smoobin_out') then
         read (array,*) f10out

c  keyword 'atmosphere' controls the output of atmosphere quantities
c           0 = do not print out the atmosphere
c           1 = print out the standard things about an atmsophere
c           2 = print standard things and additional stuff like continuous
c                    opacities, etc.
      elseif (keyword .eq. 'atmosphere') then
         read (array,*) modprintopt

c  keyword 'molecules ' controls the molecular equilibrium calculations
c           0 = do not do molecular equilibrium
c           1 = do molecular equilibrium but do not print results
c           2 = do molecular equilibrium and print results
      elseif (keyword .eq. 'molecules') then
         read (array,*) molopt
         if     (molopt .eq. 0) then
            nchars = 64
            write (array,1009)
            call getasci (nchars,l0)
            if (chinfo(1:1) .eq. 'n') then
               stop
            else
               molopt = 1
            endif
         endif

c  keyword 'molset' controls the choice of which set of molecules will be
c  used in molecular equilibrium calculations.
c          1 = the small set involving H, C, N, O, Mg, Ti (DEFAULT)
c          2 = the large set more useful for very cool stars
      elseif (keyword .eq. 'molset') then
         read (array,*) molset

c  keyword 'deviations' controls whether, for synthetic spectrum computations,
c  an 'obs-comp' plot will be made in addition to the normal spectrum plot
c           0 = do not plot the obs-comp plot
c           1 = plot the obs-comp plot
      elseif (keyword .eq. 'deviations') then
         read (array,*) deviations

c  keyword 'lines     ' controls the output of line data
c           0 = print out nothing about the input lines
c           1 = print out standard information about the input line list
c           2 = gory line data print (usually for diagnostic purposes)
      elseif (keyword .eq. 'lines') then
         read (array,*) linprintopt
         linprintalt = linprintopt

c  keyword 'gfstyle   ' controls the output of line data
c           0 = base-10 logarithms of the gf values (DEFAULT)
c           1 = straight gf values
      elseif (keyword .eq. 'gfstyle') then
         read (array,*) gfstyle

c  keyword 'contnorm  ' allows multiplicative adjustment of the
c           continuum; useful probably only for batch syntheses
c           the numbers employed should be around 1.0;
c           default is 1.000000
      elseif (keyword .eq. 'contnorm') then
         read (array,*) contnorm

c  keyword 'plotpars  ' allows you to set all of the plotting
c     parameters if you know them in advance
c     0 = none set (default); user can change in plotting routine
c     1 = given in following lines as follows
c xlow         xhi         ylo       yhi
c vshift       lamshift    obsadd    obsmult
c smooth-type  FWHM-Gauss  vsini     L.D.C.    FWHM-Macro     FWHM-Loren
      elseif (keyword .eq. 'plotpars') then
         read (array,*) iscale
         if (iscale .ne. 0) then
            read (nfparam,*) xlo, xhi, ylo, yhi
            linecount = linecount + 1
            read (nfparam,*) veladd, xadd, yadd, ymult
            if (xadd .ne. 0.) then
               veladd = 3.0d5*xadd/((xlo+xhi)/2.)
               xadd = 0.
            endif
            linecount = linecount + 1
            read (nfparam,*) smtype, fwhmgauss, vsini, limbdark, vmac,
     .                      fwhmloren
            linecount = linecount + 1
         endif

c keyword 'trudamp     '  should moog use the detailed line damping for
c                         those transitions that have information stored in
c                         subroutine trudamp? (Default is *no*)
      elseif (keyword .eq. 'trudamp') then
         read (array,*) itru

c keyword 'veladjust   '  shoud moog try to do a cross-correlation between
c                         observed and synthetic spectra and use that to
c                         align the spectra better in wavelength
c                         (Default is *no*)
      elseif (keyword .eq. 'veladjust') then
         read (array,*) maxshift

c keyword 'units      ' controls the units in which moog
c          outputs the final spectrum
c            0 = angs
c            1 = microns
c            2 = 1/cm
      elseif (keyword .eq. 'units') then
         read (array,*) iunits
         if (iunits .ne. 0) then
            write (*,1010)
            stop
         endif

c keyword 'iraf       ' allows the user to output a raw spectrum in
c          a form suitable for IRAF's rtext input command
c            0 = don't do this, make output the normal way.
c            1 = make an IRAF-compatible output
      elseif (keyword .eq. 'iraf') then
         read (array,*) iraf

c  keyword 'scat       'allows the user to employ a source function
c          which has both scattering and absorption components
c          0 = NO scattering
c          1 = scattering
      elseif (keyword .eq. 'scat') then
         read (array,*) scatopt

c  keyword 'flux/int  ' choses integrated flux or central intensity
c           0 = integrated flux calculations
c           1 = central intensity calculations
      elseif (keyword .eq. 'flux/int') then
         read (array,*) fluxintopt

c*****here are the calculations to set up the damping; for atomic lines
c     there are several options:
c        dampingopt = 0 and dampnum < 0 --->
c                             gammav = 10^{dampnum(i)}*(T/10000K)^0.3*n_HI
c        dampingopt = 0 and dampnum = 0 --->
c                             c6 = Unsold formula
c        dampingopt = 0 and dampnum > 10^(-10) --->
c                             c6 =  (Unsold formula)*dampnum(i)
c        dampingopt = 0 and dampnum(i) < 10^(-10) --->
c                             c6 = dampnum(i)
c        dampingopt = 1 --->
c                             gammav = gamma_Barklem if possible,
c                                        otherwise use dampingopt=0 options
c        dampingopt = 2 --->
c                             c6 = c6_Blackwell-group
c        dampingopt = 3 and dampnum <= 10^(-10) --->
c                             c6 = c6_NEXTGEN for H I, He I, H2
c        dampingopt = 3 and dampnum > 10^(-10) --->
c                             c6 = (c6_NEXTGEN for H I, He I, H2)*dampnum
c     for molecular lines (lacking a better idea) --->
c                                        c6 done as in dampingopt = 0
      elseif (keyword .eq. 'damping') then
         read (array,*) dampingopt

c  keyword 'obspectrum' controls the file type of the observed spectrum
c           0 = no observed spectrum is to be input
c           1 = read a true FITS file with internal read statements
c          -1 = as if obspectrum = 1, but on a byte-swapping machine
c           2 = (not implemented yet)
c           3 = read a true Fits file with the FITSIO package
c           4 = (not implemented yet)
c           5 = read a special MONGO style (wavelength, flux pair) file
      elseif (keyword .eq. 'obspectrum') then
         read (array,*) specfileopt
         if (specfileopt .lt. 0) then
            byteswap = 1
            specfileopt = iabs(specfileopt)
         endif

c   keyword 'histogram' makes histogram plots of observed spectra if
c   histoyes = 1
      elseif (keyword .eq. 'histogram') then
         read (array,*) histoyes

c  keyword 'terminal  ' gives the sm plotting window type
c           smterm = a character string of the sm window type (see the
c           appropriate sm manual for a list)
      elseif (keyword .eq. 'terminal') then
         read (array,*) smterm

c  keyword 'plot      ' decides whether or not to make a plot of results
c           0 = do not make a plot
c           For syntheses: 1 = plot only synthetic spectra
c                          2 = plot synthetic and observed spectra
c                          3 = smooth the syntheses but don't plot
c           For line analyses: # = the minimum number of lines of a
c                                  species necessary to trigger a plot
c           For curves-of-growth: 1 = make plots
c           For flux curves: 1 = make plots
      elseif (keyword .eq. 'plot') then
         read (array,*) plotopt

c  keyword 'abundances' gives the changes to be applied to the abundances
c           # = the number of different syntheses to run
c               (the next line gives the different abundance factors
c               to use)
c  minimum error check:  numatomsyn must equal numisosyn or code will stop
      elseif (keyword .eq. 'abundances') then
         neq = 0
         numpecatom = 0
         numatomsyn = 0
         newnumpecatom = 0
         newnumatomsyn = 0
         ninetynineflag = 0
         do i=1,95
            pec(i) = 0
            newpec(i) = 0
            do j=1,5
               abfactor(j) = 0.
               pecabund(i,j) = 0.
               newpecabund(i,j) = 0.
            enddo
         enddo
         read (array,*) numpecatom,numatomsyn
         if (numisosyn .ne. 0) then
            if (numatomsyn .ne. numisosyn) then
               write (array,1002) numatomsyn, numisosyn
               call putasci (77,6)
               stop
            endif
         endif
         do l=1,numpecatom
            read (nfparam,*) jatom,(deltalogab(kk),kk=1,numatomsyn)
            linecount = linecount + 1
            if (jatom .eq. 99) then
               do kk=1,numatomsyn
                  abfactor (kk) = deltalogab(kk)
               enddo
            else
               do kk=1,numatomsyn
                  pecabund(jatom,kk) = deltalogab(kk)
               enddo
               pec(jatom) = 1
            endif
         enddo
         if (numpecatom.eq.1 .and. jatom.eq.99) ninetynineflag = 1

c keyword 'isotopes   ' gives the isotopes used in the line list and their
c                       abundance relative to the parent spiecies
c  minimum error check:  numatomsyn must equal numisosyn or code will stop
      elseif (keyword .eq. 'isotopes') then
         numiso = 0
         numisosyn = 0
         newnumiso = 0
         newnumisosyn = 0
         do i=1,200
            isotope(i) = 0.
            newisotope(i) = 0.
            do j=1,5
               isoabund(i,j) = 0.
               newisoabund(i,j) = 0.
            enddo
         enddo
         read (array,*) numiso,numisosyn
         if (numatomsyn .ne. 0) then
            if (numatomsyn .ne. numisosyn) then
               write (array,1002) numatomsyn, numisosyn
               call putasci (77,6)
               stop
            endif
         endif
         do  j=1,numiso
            read (nfparam,*) isotope(j),(isoabund(j,kk),kk=1,numisosyn)
            linecount = linecount + 1
         enddo

c  keyword 'lumratio' gives the ratio of the luminosity of two stars at a
c                     specific wavelength in a binary star system (used
c                     only with driver "binary")
      elseif (keyword .eq. 'lumratio') then
         read (array,*) lumratio

c  keyword 'deltaradvel' gives the velocity difference between the stars
c                        binary star system (used only with driver "binary")
      elseif (keyword .eq. 'deltaradvel') then
         read (array,*) deltaradvel

c  keyword 'synlimits ' gives the wavelength parameters for syntheses;
c                       start and sstop are beginning and ending
c                       wavelengths, step is the step size in the
c                       syntheses, and delta is the wavelength range
c                       to either side of a synthesis point to consider
c                       for line opacity calculations
      elseif (keyword .eq. 'synlimits') then
         read (nfparam,*) start, sstop, step, delta
         oldstart = start
         oldstop  = sstop
         oldstep  = step
         olddelta = delta
         step1000 = 1000.*step
         if (dble(idnint(step1000))-step1000 .ne. 0.) then
            write (*,1008) step
            stop
         endif
         linecount = linecount + 1

c  keyword 'fluxlimits' gives the wavelength parameters for flux curves;
c                       start and sstop are beginning and ending
c                       wavelengths, and step is the step size in the
c                        flux curve
      elseif (keyword .eq. 'fluxlimits') then
         read (nfparam,*) start, sstop, step
         linecount = linecount + 1

c  keyword 'blenlimits' gives the parameters for blended line abundance
c                       matches.  delwave is the wavelength offset
c                       to the blue of first and to the red of the
c                       last line in the blend to extend the syntheses;
c                       step is the wavelength step size in the
c                       computations; cogatom is the name of the
c                       element whose abundance should be varied
c                       to achieve an EW match with observations.
      elseif (keyword .eq. 'blenlimits') then
         read (nfparam,*) delwave, step, cogatom
         linecount = linecount + 1

c  keyword 'coglimits ' gives the log(W/lambda) limits for curves-of-growth
c                       rwlow and rwhigh are the beginning
c                       and ending points of the log(red.width) values,
c                       rwstep is the step in log(red.width),
c                       cogatom is the declaration of which element
c                       will have its abundance varied (necessary only
c                       for spectrum synthesis curves-of-growth,
c                       and wavestep is a forced (if desired) step size
c                       in wavelength along the line (this applies to
c                       single line computations only
      elseif (keyword .eq. 'coglimits') then
         read (nfparam,*) rwlow, rwhigh, rwstep, wavestep, cogatom
         linecount = linecount + 1

c  keyword 'limits    ' old limits format...tell the user to change the
c                       keyword and quit.

      elseif (keyword .eq. 'limits') then
      write(*,*) 'Warning: keyword changed to *synlimits*, *coglimits*'
      write(*,*) 'for Syntesis and COG calculations.'
      write(*,*) 'Here are the proper formats:'
      write(*,*)
      write(*,*) 'synlimits <start> <stop> <step> <delta>'
      write(*,*) 'coglimits <rwlow> <rwhigh> <rwstep> <wavestep> ',
     .           '<cogatom>'
         stop

c   keyword of strong for lines which are to be considered for all of the
c   synthesis
      elseif (keyword .eq. 'strong') then
         read (array,*) dostrong

c  keyword word of opacit which takes the continuus opacity and scales it
c  with the form of kaplam(i)= kaplam(i)*((factor*10000)/t(i))
c  in Opacit.f after it calulates the normal kaplam
c  if value is <= 0 then it does not do it
      elseif (keyword .eq. 'opacit') then
         read (array,*) fudge

c  any other keyword causes great grudge
      else
         write (array,1006) keyword
         call prinfo (5)
         stop

      endif

c  loop back to get another parameter
      go to 5

c  wrap things up with a few assignments
98    if (control.eq.'gridsyn' .or. control.eq.'gridplo' .or.
     .    control.eq.'binary ' .or. control.eq.'abandy ') then
         control = 'gridend'
      endif

c  assign plotting window type; if no type has been given in the
c  parameter file, then ask for it
100   if (smterm .eq. ' ') then
         array = 'GIVE THE SM TERMINAL NAME : '
         nchar = 28
         call getasci (nchar,12)
         smterm = chinfo(1:nchar)
         ivstat = ivcleof(12,1)
      endif
      if (smterm.eq.'x11' .or. smterm.eq.'X11') then
         if    (control .eq. 'synth  ' .or.
     .          control .eq. 'synpop ' .or.
     .          control .eq. 'synplot' .or.
     .          control .eq. 'isoplot' .or.
     .          control .eq. 'gridsyn' .or.
     .          control .eq. 'gridplo' .or.
     .          control .eq. 'doflux ' .or.
     .          control .eq. 'cogsyn ' .or.
     .          control .eq. 'cog    ' .or.
     .          control .eq. 'isotop ' .or.
     .          control .eq. 'binary ') then
             smterm = smt1
         else
             smterm = smt2
         endif
      endif

c  for syntheses, store the plotting parameters
      if (control.eq.'synth  ' .or. control.eq.'synplot' .or.
     .    control.eq.'gridsyn' .or. control.eq.'gridplo' .or.
     .    control.eq.'binary ' .or. control.eq.'synpop ') then
         if (oldstart .eq. 0) then
            write (*,1011)
            stop
         endif
         if (iscale .eq. 0) call plotremember (0)
         call plotremember (1)
      endif

c*****exit normally
      return

c*****format statements
1001  format (a80)
1002  format ('# OF ABUNDANCE (',i1,') AND ISOTOPIC (',i1,')',
     .        ' SYNTHESES DO NOT AGREE!   I QUIT!       ')
1006  format ('THIS OPTION IS UNKNOWN TO MOOG: ', a10, ' I QUIT!')
1007  format (79(' '))
1008  format ('step =', f10.5, 'A but it cannot be more precise than ',
     .        'the nearest 0.001A; I QUIT!')
1009  format ('WARNING: molecular eq. always done if ',
     .        'Teff < 8000K;  OK (y/n)???')
1010  format ('the units=1 option is fragile; rerun with only ',
     .       'Angstroms and units=0')
1011  format ('SYNTHESIS START NOT SET; I QUIT!')

      end