program da_update_bc

   !-----------------------------------------------------------------------
   ! Purpose: update BC file from wrfvar output.
   ! current version reads only wrf-netcdf file format
   !
   ! Y.-R. Guo, 03/18/2008:
   !   1) Fixed the bug for low_bdy_only;
   !   2) Introducing another namelist variable: update_lsm
   !      update_lsm = .true. --- The LSM predicted variables:
   !                         TSLB, SMOIS, SNOW, SH2O, RHOSN, CANWAT, SNOWH
   !                              will be updated based on wrf_input file
   !                 = .false. -- no updated, default.
   !
   !-----------------------------------------------------------------------

   use da_netcdf_interface, only : da_get_var_3d_real_cdf, &
      da_put_var_3d_real_cdf, da_get_dims_cdf, da_put_var_2d_real_cdf, &
      da_get_var_2d_real_cdf, da_get_var_2d_int_cdf, da_get_bdytimestr_cdf, &
      da_get_times_cdf, da_get_bdyfrq, stderr, stdout, da_put_var_2d_int_cdf, &
      da_get_var_1d_real_cdf, da_get_gl_att_int_cdf

   use da_module_couple_uv, only : da_couple_uv

   implicit none

   include 'netcdf.inc'

   integer, parameter :: max_3d_variables = 20, &
                         max_2d_variables = 25

   character(len=512) :: da_file,      &
                         da_file_02,   &
                         wrf_bdy_file, &
                         wrf_input

   character(len=20) :: var_pref, var_name, vbt_name

   character(len=20) :: var3d(max_3d_variables), &
                        varsf(max_2d_variables)

   character(len=10), dimension(4) :: bdyname, tenname

   ! for WRF hybrid coordinate
   integer           :: nlevf, nlevh
   integer           :: hybrid_opt, use_theta_m
   real, allocatable :: c1f(:), c2f(:), c1h(:), c2h(:)

   integer           :: ids, ide, jds, jde, kds, kde
   integer           :: num3d, num2d, ndims
   integer           :: time_level
   integer           :: i,j,k,l,m,n

   integer, dimension(4) :: dims

   real, allocatable, dimension(:,:,:) :: tend3d, scnd3d, frst3d, full3d, full3d2

   real, allocatable, dimension(:,:,:) :: u, v, u2, v2

   real, allocatable, dimension(:,  :) :: mu, mub, msfu, msfv, msfm, &
                                          mu2, tend2d, scnd2d, frst2d, full2d

   real, allocatable, dimension(:,  :) :: tsk, tsk_wrfvar
   real, allocatable, dimension(:,:)   :: snow, snowc, snowh

   integer, allocatable, dimension(:,:) :: ivgtyp, full2dint

   character(len=80), allocatable, dimension(:) :: times, &
                                                   thisbdytime, nextbdytime

   integer :: east_end, north_end, io_status, cdfid, varid, domain_id, iswater
   integer :: iostatus(4)

   logical :: debug, update_lateral_bdy, update_low_bdy, update_lsm, keep_tsk_wrf
   logical :: keep_snow_wrf, var4d_lbc

   real :: bdyfrq

   character(len=512) :: wrfvar_output_file    ! obsolete. Kept for backward compatibility
   logical            :: cycling, low_bdy_only ! obsolete. Kept for backward compatibility

   integer, parameter :: namelist_unit = 7, &
                         ori_unit = 11, &
                         new_unit = 12

   namelist /control_param/ da_file,      &
                            da_file_02,   &
                            wrf_bdy_file, &
                            wrf_input, domain_id, var4d_lbc, &
                            debug, update_lateral_bdy, update_low_bdy, update_lsm, &
                            keep_tsk_wrf, keep_snow_wrf, iswater, &
                            wrfvar_output_file, cycling, low_bdy_only

   da_file            = 'wrfvar_output'
   da_file_02         = 'ana02'
   wrf_bdy_file       = 'wrfbdy_d01'
   wrf_input          = 'wrfinput_d01'
   domain_id          = 1

   var4d_lbc          = .false.
   debug              = .false.
   update_lateral_bdy = .true.
   update_low_bdy     = .true.
   update_lsm         = .false.
   keep_tsk_wrf       = .true.
   keep_snow_wrf      = .true.
   iswater            = 16      ! USGS water index: 16, MODIS water index: 17

   wrfvar_output_file = 'OBSOLETE'
   cycling            = .false.
   low_bdy_only       = .false.

   !---------------------------------------------------------------------
   ! Read namelist
   !---------------------------------------------------------------------
   io_status = 0

   open(unit = namelist_unit, file = 'parame.in', &
          status = 'old' , access = 'sequential', &
          form   = 'formatted', action = 'read', &
          iostat = io_status)

   if (io_status /= 0) then
      write(unit=stdout,fmt=*) 'Error to open namelist file: parame.in.'
      write(unit=stdout,fmt=*) 'Will work for updating lateral boundary only.'
   else
      read(unit=namelist_unit, nml = control_param , iostat = io_status)

      if (io_status /= 0) then
         write(unit=stdout,fmt=*) 'Error to read control_param. Stopped.'
         stop
      end if

      ! deal with the old namelist
      if ( index(wrfvar_output_file, 'OBSOLETE') <= 0 ) then
         ! wrfvar_output_file is set in the user's parame.in
         ! reset the settings
         da_file = wrfvar_output_file
         if ( domain_id > 1 ) then
            low_bdy_only = .true.
         end if
         if ( cycling .and. domain_id == 1 ) then
            update_lateral_bdy = .true.
            update_low_bdy     = .true.
         else
            if ( low_bdy_only ) then
               update_lateral_bdy = .false.
               update_low_bdy     = .true.
            else
               update_lateral_bdy = .true.
               update_low_bdy     = .false.
            end if
         end if
      end if

      WRITE(unit=stdout, fmt='(2a)') &
           'da_file       = ', trim(da_file), &
           'da_file_02    = ', trim(da_file_02), &
           'wrf_bdy_file  = ', trim(wrf_bdy_file), &
           'wrf_input     = ', trim(wrf_input)

      WRITE(unit=stdout, fmt='(2(a, L10))')             &
           'update_lateral_bdy = ', update_lateral_bdy, &
           'update_low_bdy     = ', update_low_bdy

      if ( update_lsm ) keep_snow_wrf = .false.

      close(unit=namelist_unit)
   end if

   ! 3D need update
   num3d=5
   var3d(1)='U'
   var3d(2)='V'
   var3d(3)='T'
   var3d(4)='PH'
   var3d(5)='QVAPOR'
!  var3d(6)='W'

   ! 2D need update
   num2d=23
   varsf(1)='MUB'
   varsf(2)='MU'
   varsf(3)='MAPFAC_U'
   varsf(4)='MAPFAC_V'
   varsf(5)='MAPFAC_M'
   varsf(6)='TMN'
   varsf(7)='SST'
   varsf(8)='TSK'
   varsf(9)='VEGFRA'
   varsf(10)='ALBBCK'
   varsf(11)='TSLB'
   varsf(12)='SMOIS'
   varsf(13)='SNOW'
   varsf(14)='SEAICE'
   varsf(15)='SH2O'
   varsf(16)='CANWAT'
   varsf(17)='RHOSN'
   varsf(18)='SNOWH'
   varsf(19)='LANDMASK'
   varsf(20)='IVGTYP'
   varsf(21)='ISLTYP'
   varsf(22)='SNOWC'
   varsf(23)='XLAND'

   if ( domain_id > 1 ) then
      write(unit=stdout, fmt='(a,i2)') 'Nested domain ID=',domain_id
      write(unit=stdout, fmt='(a)') &
        'No wrfbdy file needed, only low boundary need to be updated.'
      if ( update_lateral_bdy ) then
         write(unit=stdout, fmt='(a)') &
            'Re-setting update_lateral_bdy to be false for nested domain.'
         update_lateral_bdy = .false.
      end if
      update_low_bdy     = .true.
   end if

   if ( update_lateral_bdy ) then
   ! First, the boundary times
   call da_get_dims_cdf(wrf_bdy_file, 'Times', dims, ndims, debug)

   if (debug) then
      write(unit=stdout, fmt='(a,i2,2x,a,4i6)') &
           'Times: ndims=', ndims, 'dims=', (dims(i), i=1,ndims)
   end if

   time_level = dims(2)

   if (time_level < 1) then
      write(unit=stdout, fmt='(a,i2/a)') &
           'time_level = ', time_level, &
           'We need at least one time-level BDY.'
      stop 'Wrong BDY file.'
   end if

   allocate(times(dims(2)))
   allocate(thisbdytime(dims(2)))
   allocate(nextbdytime(dims(2)))

   call da_get_times_cdf(wrf_bdy_file, times, dims(2), dims(2), debug)

   call da_get_bdytimestr_cdf(wrf_bdy_file, 'thisbdytime', thisbdytime, dims(2), debug)
   call da_get_bdytimestr_cdf(wrf_bdy_file, 'nextbdytime', nextbdytime, dims(2), debug)

   call da_get_bdyfrq(thisbdytime(1), nextbdytime(1), bdyfrq, debug)

   if (debug) then
      do n=1, dims(2)
         write(unit=stdout, fmt='(3(a, i2, 2a,2x))') &
           '       times(', n, ')=', trim(times(n)), &
           'thisbdytime (', n, ')=', trim(thisbdytime(n)), &
           'nextbdytime (', n, ')=', trim(nextbdytime(n))
      end do
   end if

   end if

   east_end=0
   north_end=0

   cdfid = ncopn(da_file, NCWRITE, io_status )

   ! for WRF hybrid coordinate

   call da_get_gl_att_int_cdf(da_file, 'BOTTOM-TOP_PATCH_END_STAG',   nlevf, debug, io_status)
   call da_get_gl_att_int_cdf(da_file, 'BOTTOM-TOP_PATCH_END_UNSTAG', nlevh, debug, io_status)
   if ( io_status /= NF_NOERR .or. nlevf <= 0 .or. nlevh <= 0 ) then
      write(unit=stdout,fmt=*) 'Error finding the number of vertical levels'
      stop
   else
      allocate ( c1f(nlevf) )
      allocate ( c2f(nlevf) )
      allocate ( c1h(nlevh) )
      allocate ( c2h(nlevh) )
   end if

   ! initialize as use_theta_m = 0
   use_theta_m = 0
   call da_get_gl_att_int_cdf(da_file, 'USE_THETA_M', use_theta_m, debug, io_status)
   write(stdout,*) 'use_theta_m = ', use_theta_m

   ! initialize as hybrid_opt = 0
   hybrid_opt = 0
   c1f(:) = 1.0
   c2f(:) = 0.0
   c1h(:) = 1.0
   c2h(:) = 0.0

   call da_get_gl_att_int_cdf(da_file, 'HYBRID_OPT', hybrid_opt, debug, io_status)
   if ( io_status == NF_NOERR .and. hybrid_opt > 0 ) then
      ! when HYBRID_OPT is available from the file (V3.9 and later)
      ! use C1F,C2F,C1H,C2H from the file
      call da_get_var_1d_real_cdf( da_file, 'C1F', c1f, nlevf, 1, debug)
      call da_get_var_1d_real_cdf( da_file, 'C2F', c2f, nlevf, 1, debug)
      call da_get_var_1d_real_cdf( da_file, 'C1H', c1h, nlevh, 1, debug)
      call da_get_var_1d_real_cdf( da_file, 'C2H', c2h, nlevh, 1, debug)
   end if

   write(stdout,*) 'hybrid_opt = ', hybrid_opt
   if ( debug ) then
      write(stdout,*) 'c1f = ', c1f
      write(stdout,*) 'c2f = ', c2f
      write(stdout,*) 'c1h = ', c1h
      write(stdout,*) 'c2h = ', c2f
   end if

   ! For 2D variables
   ! Get mu, mub, msfu, and msfv

   do n=1,num2d

      io_status = nf_inq_varid(cdfid, trim(varsf(n)), varid)
      if (io_status /= 0 ) then
         print '(/"N=",i2," io_status=",i5,5x,"VAR=",a,a)', &
                   n, io_status, trim(varsf(n)), " does not exist"
         cycle
      endif

      call da_get_dims_cdf( da_file, trim(varsf(n)), dims, &
         ndims, debug)

      select case(trim(varsf(n)))
      case ('MU') ;
         if ( .not. update_lateral_bdy ) cycle

         allocate(mu(dims(1), dims(2)))

         call da_get_var_2d_real_cdf( da_file, &
            trim(varsf(n)), mu, dims(1), dims(2), 1, debug)

         east_end=dims(1)+1
         north_end=dims(2)+1

         if ( var4d_lbc ) then
            allocate(mu2(dims(1), dims(2)))

            call da_get_var_2d_real_cdf( da_file_02, &
               trim(varsf(n)), mu2, dims(1), dims(2), 1, debug)
         end if
      case ('MUB') ;
         if ( .not. update_lateral_bdy ) cycle

         allocate(mub(dims(1), dims(2)))

         call da_get_var_2d_real_cdf( da_file, trim(varsf(n)), mub, &
                                   dims(1), dims(2), 1, debug)
      case ('MAPFAC_U') ;
         if ( .not. update_lateral_bdy ) cycle

         allocate(msfu(dims(1), dims(2)))

         call da_get_var_2d_real_cdf( da_file, trim(varsf(n)), msfu, &
                                   dims(1), dims(2), 1, debug)
      case ('MAPFAC_V') ;
         if ( .not. update_lateral_bdy ) cycle

         allocate(msfv(dims(1), dims(2)))

         call da_get_var_2d_real_cdf( da_file, trim(varsf(n)), msfv, &
                                   dims(1), dims(2), 1, debug)
      case ('MAPFAC_M') ;
         if ( .not. update_lateral_bdy ) cycle

         allocate(msfm(dims(1), dims(2)))

         call da_get_var_2d_real_cdf( da_file, trim(varsf(n)), msfm, &
                                   dims(1), dims(2), 1, debug)
      case ('TSK') ;
         if ( .not. update_low_bdy ) cycle

         allocate(tsk(dims(1), dims(2)))
         allocate(tsk_wrfvar(dims(1), dims(2)))
         allocate(ivgtyp(dims(1), dims(2)))

         call da_get_var_2d_real_cdf( wrf_input, trim(varsf(n)), tsk, &
                                   dims(1), dims(2), 1, debug)

         if ( keep_tsk_wrf ) then
            call da_get_var_2d_real_cdf( da_file, trim(varsf(n)), tsk_wrfvar, &
                                      dims(1), dims(2), 1, debug)
            !hcl call da_get_var_2d_int_cdf( da_file, 'IVGTYP', ivgtyp, &
            call da_get_var_2d_int_cdf( wrf_input, 'IVGTYP', ivgtyp, &
                                      dims(1), dims(2), 1, debug)
            ! update TSK.
            do j=1,dims(2)
               do i=1,dims(1)
                  if (ivgtyp(i,j) /= iswater)  tsk(i,j)=tsk_wrfvar(i,j)
               end do
            end do
         end if

            call da_put_var_2d_real_cdf( da_file, trim(varsf(n)), tsk, &
                                      dims(1), dims(2), 1, debug)
            deallocate(tsk)
            deallocate(ivgtyp)
            deallocate(tsk_wrfvar)

         !hcl case ('TMN', 'SST', 'VEGFRA', 'ALBBCK', 'SEAICE') ;
         case ('TMN', 'SST', 'VEGFRA', 'ALBBCK', 'SEAICE', 'LANDMASK', 'XLAND') ;
            if ( .not. update_low_bdy ) cycle

            allocate(full2d(dims(1), dims(2)))

            call da_get_var_2d_real_cdf( wrf_input, trim(varsf(n)), full2d, &
                                      dims(1), dims(2), 1, debug)

            call da_put_var_2d_real_cdf( da_file, trim(varsf(n)), full2d, &
                                      dims(1), dims(2), 1, debug)
            deallocate(full2d)

         case ('IVGTYP', 'ISLTYP') ;  !hcl add
            if ( .not. update_low_bdy ) cycle

            allocate(full2dint(dims(1), dims(2)))

            call da_get_var_2d_int_cdf( wrf_input, trim(varsf(n)), full2dint, &
                                      dims(1), dims(2), 1, debug)

            call da_put_var_2d_int_cdf( da_file, trim(varsf(n)), full2dint, &
                                      dims(1), dims(2), 1, debug)
            deallocate(full2dint)

         case ('SNOW', 'RHOSN', 'SNOWH', 'SNOWC') ;
            if ( (.not. update_lsm) .and. (.not. update_low_bdy) ) cycle
            if ( keep_snow_wrf ) cycle
               allocate(full2d(dims(1), dims(2)))

               call da_get_var_2d_real_cdf( wrf_input, trim(varsf(n)), full2d, &
                                      dims(1), dims(2), 1, debug )

               call da_put_var_2d_real_cdf( da_file, trim(varsf(n)), full2d, &
                                      dims(1), dims(2), 1, debug )
               deallocate(full2d)

         case ('CANWAT') ;
            if ( .not. update_lsm ) cycle
               allocate(full2d(dims(1), dims(2)))

               call da_get_var_2d_real_cdf( wrf_input, trim(varsf(n)), full2d, &
                                      dims(1), dims(2), 1, debug )
!               print *,"sum(full2d^2)=", sum(full2d*full2d)

               call da_put_var_2d_real_cdf( da_file, trim(varsf(n)), full2d, &
                                      dims(1), dims(2), 1, debug )
               deallocate(full2d)

         case ('TSLB', 'SMOIS', 'SH2O') ;
            if( .not. update_lsm ) cycle
               allocate(full3d(dims(1), dims(2), dims(3)))

               call da_get_var_3d_real_cdf( wrf_input, trim(varsf(n)), full3d, &
                                      dims(1), dims(2), dims(3), 1, debug )
!               print *,"sum(full3d^2)=", sum(full3d*full3d)

               call da_put_var_3d_real_cdf( da_file, trim(varsf(n)), full3d, &
                                      dims(1), dims(2), dims(3), 1, debug )
               deallocate(full3d)

         case default ;
            write(unit=stdout,fmt=*) 'It is impossible here. varsf(n)=', trim(varsf(n))
      end select
   end do

   ! check for snow over water
   iostatus(1) = nf_inq_varid(cdfid, 'IVGTYP', varid)
   iostatus(2) = nf_inq_varid(cdfid, 'SNOW',   varid)
   iostatus(3) = nf_inq_varid(cdfid, 'SNOWC',  varid)
   iostatus(4) = nf_inq_varid(cdfid, 'SNOWH',  varid)
   if ( iostatus(1) == 0 ) then
      allocate(snow(dims(1), dims(2)))
      allocate(snowc(dims(1), dims(2)))
      allocate(snowh(dims(1), dims(2)))
      allocate(ivgtyp(dims(1), dims(2)))
      if ( iostatus(1) == 0 ) then
         call da_get_var_2d_int_cdf( da_file, 'IVGTYP', ivgtyp,    &
                               dims(1), dims(2), 1, debug)
      end if
      if ( iostatus(2) == 0 ) then
         call da_get_var_2d_real_cdf( da_file, 'SNOW',    snow,     &
                                dims(1), dims(2), 1, debug)
      end if
      if ( iostatus(3) == 0 ) then
         call da_get_var_2d_real_cdf( da_file, 'SNOWC',  snowc,     &
                                dims(1), dims(2), 1, debug)
      end if
      if ( iostatus(4) == 0 ) then
         call da_get_var_2d_real_cdf( da_file, 'SNOWH',  snowh,     &
                                dims(1), dims(2), 1, debug)
      end if
      if ( iostatus(2) == 0 ) then
         do j = 1, dims(2)
            do i = 1, dims(1)
               if (ivgtyp(i,j) == iswater)  then
                  if ( snow(i,j) > 0.0 ) then
                     write(unit=stdout,fmt=*) 'Remove snow over water at i, j = ', i, j
                     if ( iostatus(2) == 0 ) snow(i,j)  = 0.0
                     if ( iostatus(3) == 0 ) snowc(i,j) = 0.0
                     if ( iostatus(4) == 0 ) snowh(i,j) = 0.0
                  end if
               end if
            end do
         end do
      end if
      if ( iostatus(2) == 0 ) then
         call da_put_var_2d_real_cdf( da_file, 'SNOW',   snow, &
                                dims(1), dims(2), 1, debug)
      end if
      if ( iostatus(3) == 0 ) then
         call da_put_var_2d_real_cdf( da_file, 'SNOWC',  snowc, &
                                dims(1), dims(2), 1, debug)
      end if
      if ( iostatus(4) == 0 ) then
         call da_put_var_2d_real_cdf( da_file, 'SNOWH',  snowh, &
                                dims(1), dims(2), 1, debug)
      end if
      deallocate(snow)
      deallocate(snowc)
      deallocate(snowh)
      deallocate(ivgtyp)
   end if

 if ( update_lateral_bdy ) then

   if (east_end < 1 .or. north_end < 1) then
      write(unit=stdout, fmt='(a)') 'Wrong data for Boundary.'
      stop
   end if

   write(unit=stdout,fmt='(/a/)') 'Processing the lateral boundary condition:'

   ! boundary variables
   bdyname(1)='_BXS'
   bdyname(2)='_BXE'
   bdyname(3)='_BYS'
   bdyname(4)='_BYE'

   ! boundary tendancy variables
   tenname(1)='_BTXS'
   tenname(2)='_BTXE'
   tenname(3)='_BTYS'
   tenname(4)='_BTYE'

   do m=1,4
      var_name='MU' // trim(bdyname(m))
      vbt_name='MU' // trim(tenname(m))

      call da_get_dims_cdf( wrf_bdy_file, trim(var_name), dims, ndims, debug)

      allocate(frst2d(dims(1), dims(2)))
      allocate(scnd2d(dims(1), dims(2)))
      allocate(tend2d(dims(1), dims(2)))

      ! Get variable at second time level
      if ( .not. var4d_lbc ) then
         if (time_level > 1) then
            call da_get_var_2d_real_cdf( wrf_bdy_file, trim(var_name), scnd2d, &
                                      dims(1), dims(2), 2, debug)
         else
            call da_get_var_2d_real_cdf( wrf_bdy_file, trim(var_name), frst2d, &
                                      dims(1), dims(2), 1, debug)
            call da_get_var_2d_real_cdf( wrf_bdy_file, trim(vbt_name), tend2d, &
                                      dims(1), dims(2), 1, debug)
         end if
      end if

      if (debug) then
         write(unit=ori_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
              'No.', m, 'Variable: ', trim(vbt_name), &
              'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

         call da_get_var_2d_real_cdf( wrf_bdy_file, trim(vbt_name), tend2d, &
                                   dims(1), dims(2), 1, debug)

         write(unit=ori_unit, fmt='(a, 10i12)') &
              ' old ', (i, i=1,dims(2))
         do j=1,dims(1)
            write(unit=ori_unit, fmt='(i4, 1x, 10e20.7)') &
                  j, (tend2d(j,i), i=1,dims(2))
         end do
      end if

      ! calculate variable at first time level
      select case(m)
      case (1) ;             ! West boundary
         do l=1,dims(2)
            do j=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
                  scnd2d(j,l)=frst2d(j,l)+tend2d(j,l)*bdyfrq
               if (var4d_lbc) scnd2d(j,l)=mu2(l,j)
               frst2d(j,l)=mu(l,j)
            end do
         end do
      case (2) ;             ! East boundary
         do l=1,dims(2)
            do j=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
                  scnd2d(j,l)=frst2d(j,l)+tend2d(j,l)*bdyfrq
               if (var4d_lbc) scnd2d(j,l)=mu2(east_end-l,j)
               frst2d(j,l)=mu(east_end-l,j)
            end do
         end do
      case (3) ;             ! South boundary
         do l=1,dims(2)
            do i=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
                  scnd2d(i,l)=frst2d(i,l)+tend2d(i,l)*bdyfrq
               if (var4d_lbc) scnd2d(i,l)=mu2(i,l)
               frst2d(i,l)=mu(i,l)
            end do
         end do
      case (4) ;             ! North boundary
         do l=1,dims(2)
            do i=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
                  scnd2d(i,l)=frst2d(i,l)+tend2d(i,l)*bdyfrq
               if (var4d_lbc) scnd2d(i,l)=mu2(i,north_end-l)
               frst2d(i,l)=mu(i,north_end-l)
            end do
         end do
      case default ;
         write(unit=stdout,fmt=*) 'It is impossible here. mu, m=', m
      end select

      ! calculate new tendancy
      do l=1,dims(2)
         do i=1,dims(1)
            tend2d(i,l)=(scnd2d(i,l)-frst2d(i,l))/bdyfrq
         end do
      end do

      if (debug) then
         write(unit=new_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
              'No.', m, 'Variable: ', trim(vbt_name), &
              'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

         write(unit=new_unit, fmt='(a, 10i12)') &
              ' new ', (i, i=1,dims(2))

         do j=1,dims(1)
            write(unit=new_unit, fmt='(i4, 1x, 10e20.7)') &
                  j, (tend2d(j,i), i=1,dims(2))
         end do
      end if

      ! output new variable at first time level
      call da_put_var_2d_real_cdf( wrf_bdy_file, trim(var_name), frst2d, &
                                dims(1), dims(2), 1, debug)
      ! output new tendancy
      call da_put_var_2d_real_cdf( wrf_bdy_file, trim(vbt_name), tend2d, &
                                dims(1), dims(2), 1, debug)

      deallocate(frst2d)
      deallocate(scnd2d)
      deallocate(tend2d)
   end do

   !---------------------------------------------------------------------
   ! For 3D variables

   ! Get U
   call da_get_dims_cdf( da_file, 'U', dims, ndims, debug)

   ! call da_get_att_cdf( da_file, 'U', debug)

   allocate(u(dims(1), dims(2), dims(3)))

   ids=1
   ide=dims(1)-1
   jds=1
   jde=dims(2)
   kds=1
   kde=dims(3)

   call da_get_var_3d_real_cdf( da_file, 'U', u, &
                             dims(1), dims(2), dims(3), 1, debug)
   if ( var4d_lbc ) then
      allocate(u2(dims(1), dims(2), dims(3)))
      call da_get_var_3d_real_cdf( da_file_02, 'U', u2, &
                                dims(1), dims(2), dims(3), 1, debug)
   end if

   ! do j=1,dims(2)
   !    write(unit=stdout, fmt='(2(a,i5), a, f12.8)') &
   !       'u(', dims(1), ',', j, ',1)=', u(dims(1),j,1)
   ! end do

   ! Get V
   call da_get_dims_cdf( da_file, 'V', dims, ndims, debug)

   ! call da_get_att_cdf( da_file, 'V', debug)

   allocate(v(dims(1), dims(2), dims(3)))

   call da_get_var_3d_real_cdf( da_file, 'V', v, &
                             dims(1), dims(2), dims(3), 1, debug)
   if ( var4d_lbc ) then
      allocate(v2(dims(1), dims(2), dims(3)))
      call da_get_var_3d_real_cdf( da_file_02, 'V', v2, &
                                dims(1), dims(2), dims(3), 1, debug)
   end if

   ! do i=1,dims(1)
   !    write(unit=stdout, fmt='(2(a,i5), a, f12.8)') &
   !       'v(', i, ',', dims(2), ',1)=', v(i,dims(2),1)
   ! end do

   if (debug) then
      write(unit=stdout, fmt='(a,e20.12,4x)') &
           'Before couple Sample u=', u(dims(1)/2,dims(2)/2,dims(3)/2), &
           'Before couple Sample v=', v(dims(1)/2,dims(2)/2,dims(3)/2)
   end if

   !---------------------------------------------------------------------
   ! Couple u, v.
   call da_couple_uv ( u, v, mu, mub, msfu, msfv, c1h, c2h, ids, ide, jds, jde, kds, kde)
   if ( var4d_lbc ) then
      call da_couple_uv ( u2, v2, mu2, mub, msfu, msfv, c1h, c2h, ids, ide, jds, jde, kds, kde)
   end if

   if (debug) then
      write(unit=stdout, fmt='(a,e20.12,4x)') &
           'After  couple Sample u=', u(dims(1)/2,dims(2)/2,dims(3)/2), &
           'After  couple Sample v=', v(dims(1)/2,dims(2)/2,dims(3)/2)
   end if

   !---------------------------------------------------------------------
   !For 3D variables

   do n=1,num3d
      write(unit=stdout, fmt='(a, i3, 2a)') 'Processing: var3d(', n, ')=', trim(var3d(n))

      call da_get_dims_cdf( da_file, trim(var3d(n)), dims, ndims, debug)

      allocate(full3d(dims(1), dims(2), dims(3)))
      if ( var4d_lbc ) allocate(full3d2(dims(1), dims(2), dims(3)))

      east_end=dims(1)+1
      north_end=dims(2)+1

      select case(trim(var3d(n)))
      case ('U') ;           ! U
         ! var_pref='R' // trim(var3d(n))
         var_pref=trim(var3d(n))
         full3d(:,:,:)=u(:,:,:)
         if ( var4d_lbc ) full3d2(:,:,:)=u2(:,:,:)
      case ('V') ;           ! V
         ! var_pref='R' // trim(var3d(n))
         var_pref=trim(var3d(n))
         full3d(:,:,:)=v(:,:,:)
         if ( var4d_lbc ) full3d2(:,:,:)=v2(:,:,:)
      case ('W') ;
         ! var_pref = 'R' // trim(var3d(n))
         var_pref = trim(var3d(n))

         call da_get_var_3d_real_cdf( da_file, trim(var3d(n)), &
            full3d, dims(1), dims(2), dims(3), 1, debug)
         if ( var4d_lbc ) &
            call da_get_var_3d_real_cdf( da_file_02, trim(var3d(n)), &
               full3d2, dims(1), dims(2), dims(3), 1, debug)

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'Before couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if

         do k=1,dims(3)
            do j=1,dims(2)
               do i=1,dims(1)
                  full3d(i,j,k)=full3d(i,j,k)*(c1f(k)*(mu(i,j)+mub(i,j))+c2f(k))/msfm(i,j)
                  if ( var4d_lbc ) full3d2(i,j,k)=full3d2(i,j,k)*(c1f(k)*(mu2(i,j)+mub(i,j))+c2f(k))/msfm(i,j)
               end do
            end do
         end do

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'After  couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if
      case ('T', 'PH') ;
         var_pref=trim(var3d(n))

         if ( use_theta_m > 0 .and. trim(var3d(n)) == 'T' ) then
           call da_get_var_3d_real_cdf( da_file, 'THM', &
              full3d, dims(1), dims(2), dims(3), 1, debug)
           if ( var4d_lbc ) &
              call da_get_var_3d_real_cdf( da_file_02, 'THM', &
                 full3d2, dims(1), dims(2), dims(3), 1, debug)
         else
           call da_get_var_3d_real_cdf( da_file, trim(var3d(n)), &
              full3d, dims(1), dims(2), dims(3), 1, debug)
           if ( var4d_lbc ) &
              call da_get_var_3d_real_cdf( da_file_02, trim(var3d(n)), &
                 full3d2, dims(1), dims(2), dims(3), 1, debug)
         end if

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'Before couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if

         if ( dims(3) == nlevf ) then
            ! applying c1f and c2f for mu
            do k=1,dims(3)
               do j=1,dims(2)
                  do i=1,dims(1)
                     full3d(i,j,k)=full3d(i,j,k)*(c1f(k)*(mu(i,j)+mub(i,j))+c2f(k))
                     if ( var4d_lbc ) full3d2(i,j,k)=full3d2(i,j,k)*(c1f(k)*(mu2(i,j)+mub(i,j))+c2f(k))
                  end do
               end do
            end do
         else if ( dims(3) == nlevh ) then
            ! applying c1h and c2h for mu
            do k=1,dims(3)
               do j=1,dims(2)
                  do i=1,dims(1)
                     full3d(i,j,k)=full3d(i,j,k)*(c1h(k)*(mu(i,j)+mub(i,j))+c2h(k))
                     if ( var4d_lbc ) full3d2(i,j,k)=full3d2(i,j,k)*(c1h(k)*(mu2(i,j)+mub(i,j))+c2h(k))
                  end do
               end do
            end do
         else
            write(unit=stdout,fmt=*) 'Error finding matched dimensions.'
            stop
         end if

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'After  couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if
      case ('QVAPOR', 'QCLOUD', 'QRAIN', 'QICE', 'QSNOW', 'QGRAUP') ;
         ! var_pref='R' // var3d(n)(1:2)
         ! var_pref=var3d(n)(1:2)
         var_pref=var3d(n)

         call da_get_var_3d_real_cdf( da_file, trim(var3d(n)), &
            full3d, dims(1), dims(2), dims(3), 1, debug)
         if ( var4d_lbc ) &
            call da_get_var_3d_real_cdf( da_file_02, trim(var3d(n)), &
               full3d2, dims(1), dims(2), dims(3), 1, debug)

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'Before couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if

         do k=1,dims(3)
            do j=1,dims(2)
               do i=1,dims(1)
                  full3d(i,j,k)=full3d(i,j,k)*(c1h(k)*(mu(i,j)+mub(i,j))+c2h(k))
                  if ( var4d_lbc ) full3d2(i,j,k)=full3d2(i,j,k)*(c1h(k)*(mu2(i,j)+mub(i,j))+c2h(k))
               end do
            end do
         end do

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'After  couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if
      case default ;
         write(unit=stdout,fmt=*) 'It is impossible here. var3d(', n, ')=', trim(var3d(n))
      end select

      do m=1,4
         var_name=trim(var_pref) // trim(bdyname(m))
         vbt_name=trim(var_pref) // trim(tenname(m))

         write(unit=stdout, fmt='(a, i3, 2a)') &
            'Processing: bdyname(', m, ')=', trim(var_name)

         call da_get_dims_cdf( wrf_bdy_file, trim(var_name), dims, ndims, debug)

         allocate(frst3d(dims(1), dims(2), dims(3)))
         allocate(scnd3d(dims(1), dims(2), dims(3)))
         allocate(tend3d(dims(1), dims(2), dims(3)))

         ! Get variable at second time level
         if ( .not. var4d_lbc ) then
            if (time_level > 1) then
               call da_get_var_3d_real_cdf( wrf_bdy_file, trim(var_name), scnd3d, &
                                         dims(1), dims(2), dims(3), 2, debug)
            else
               call da_get_var_3d_real_cdf( wrf_bdy_file, trim(var_name), frst3d, &
                                         dims(1), dims(2), dims(3), 1, debug)
               call da_get_var_3d_real_cdf( wrf_bdy_file, trim(vbt_name), tend3d, &
                                         dims(1), dims(2), dims(3), 1, debug)
            end if
         end if

         if (debug) then
            write(unit=ori_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
                 'No.', m, 'Variable: ', trim(vbt_name), &
                 'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

            call da_get_var_3d_real_cdf( wrf_bdy_file, trim(vbt_name), tend3d, &
                                      dims(1), dims(2), dims(3), 1, debug)

            write(unit=ori_unit, fmt='(a, 10i12)') &
                 ' old ', (i, i=1,dims(3))
            do j=1,dims(1)
               write(unit=ori_unit, fmt='(i4, 1x, 10e20.7)') &
                     j, (tend3d(j,dims(2)/2,i), i=1,dims(3))
            end do
         end if

         select case(trim(bdyname(m)))
         case ('_BXS') ;             ! West boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do j=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
               scnd3d(j,k,l)=frst3d(j,k,l)+tend3d(j,k,l)*bdyfrq
               if ( var4d_lbc ) scnd3d(j,k,l)=full3d2(l,j,k)
               frst3d(j,k,l)=full3d(l,j,k)
            end do
            end do
            end do
         case ('_BXE') ;             ! East boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do j=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
               scnd3d(j,k,l)=frst3d(j,k,l)+tend3d(j,k,l)*bdyfrq
               if ( var4d_lbc ) scnd3d(j,k,l)=full3d2(east_end-l,j,k)
               frst3d(j,k,l)=full3d(east_end-l,j,k)
            end do
            end do
            end do
         case ('_BYS') ;             ! South boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do i=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
               scnd3d(i,k,l)=frst3d(i,k,l)+tend3d(i,k,l)*bdyfrq
               if ( var4d_lbc )scnd3d(i,k,l)=full3d2(i,l,k)
               frst3d(i,k,l)=full3d(i,l,k)
            end do
            end do
            end do
         case ('_BYE') ;             ! North boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do i=1,dims(1)
               if (time_level < 2 .and. .not. var4d_lbc) &
               scnd3d(i,k,l)=frst3d(i,k,l)+tend3d(i,k,l)*bdyfrq
               if ( var4d_lbc ) scnd3d(i,k,l)=full3d2(i,north_end-l,k)
               frst3d(i,k,l)=full3d(i,north_end-l,k)
            end do
            end do
            end do
         case default ;
            write(unit=stdout,fmt=*) 'It is impossible here.'
            write(unit=stdout,fmt=*) 'bdyname(', m, ')=', trim(bdyname(m))
            stop
         end select

         write(unit=stdout, fmt='(a, i3, 2a)') &
            'cal. tend: bdyname(', m, ')=', trim(vbt_name)

         ! calculate new tendancy
         do l=1,dims(3)
            do k=1,dims(2)
               do i=1,dims(1)
                  tend3d(i,k,l)=(scnd3d(i,k,l)-frst3d(i,k,l))/bdyfrq
               end do
            end do
         end do

         if (debug) then
            write(unit=new_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
                 'No.', m, 'Variable: ', trim(vbt_name), &
                 'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

            write(unit=new_unit, fmt='(a, 10i12)') &
                 ' new ', (i, i=1,dims(3))

            do j=1,dims(1)
               write(unit=new_unit, fmt='(i4, 1x, 10e20.7)') &
                     j, (tend3d(j,dims(2)/2,i), i=1,dims(3))
            end do
         end if

         ! output new variable at first time level
         call da_put_var_3d_real_cdf( wrf_bdy_file, trim(var_name), frst3d, &
                                dims(1), dims(2), dims(3), 1, debug)
         call da_put_var_3d_real_cdf( wrf_bdy_file, trim(vbt_name), tend3d, &
                                   dims(1), dims(2), dims(3), 1, debug)

         deallocate(frst3d)
         deallocate(scnd3d)
         deallocate(tend3d)
      end do

      deallocate(full3d)
      if ( var4d_lbc ) deallocate(full3d2)
   end do

   deallocate(mu)
   if ( var4d_lbc ) deallocate(mu2)
   deallocate(u)
   if ( var4d_lbc ) deallocate(u2)
   deallocate(v)
   if ( var4d_lbc ) deallocate(v2)

!--------------------- second time level-----------------------------------------
!- for var4d_lbc, we need to update the second time level LBC
   if ( var4d_lbc .and. update_lateral_bdy .and. time_level > 1 ) then

   east_end=0
   north_end=0

   cdfid = ncopn(da_file_02, NCNOWRIT, io_status )

   ! For 2D variables
   ! Get mu, mub, msfu, and msfv

   io_status = nf_inq_varid(cdfid, trim(varsf(n)), varid)
   if (io_status /= 0 ) then
      print '(/"N=",i2," io_status=",i5,5x,"VAR=",a,a)', &
                n, io_status, trim(varsf(n)), " does not exist"
      stop
   endif

   call da_get_dims_cdf( da_file_02, 'MU', dims, &
      ndims, debug)

   allocate(mu(dims(1), dims(2)))

   call da_get_var_2d_real_cdf( da_file_02, &
      'MU', mu, dims(1), dims(2), 1, debug)

   east_end=dims(1)+1
   north_end=dims(2)+1

   if (east_end < 1 .or. north_end < 1) then
      write(unit=stdout, fmt='(a)') 'Wrong data for Boundary.'
      stop
   end if

   write(unit=stdout,fmt='(/a/)') 'Processing the lateral boundary condition:'

   ! boundary variables
   bdyname(1)='_BXS'
   bdyname(2)='_BXE'
   bdyname(3)='_BYS'
   bdyname(4)='_BYE'

   ! boundary tendancy variables
   tenname(1)='_BTXS'
   tenname(2)='_BTXE'
   tenname(3)='_BTYS'
   tenname(4)='_BTYE'

   do m=1,4
      var_name='MU' // trim(bdyname(m))
      vbt_name='MU' // trim(tenname(m))

      call da_get_dims_cdf( wrf_bdy_file, trim(var_name), dims, ndims, debug)

      allocate(frst2d(dims(1), dims(2)))
      allocate(scnd2d(dims(1), dims(2)))
      allocate(tend2d(dims(1), dims(2)))

      ! Get variable at third time level
      if (time_level > 2) then
         call da_get_var_2d_real_cdf( wrf_bdy_file, trim(var_name), scnd2d, &
                                   dims(1), dims(2), 3, debug)
      else
         call da_get_var_2d_real_cdf( wrf_bdy_file, trim(var_name), frst2d, &
                                   dims(1), dims(2), 2, debug)
         call da_get_var_2d_real_cdf( wrf_bdy_file, trim(vbt_name), tend2d, &
                                   dims(1), dims(2), 2, debug)
      end if

      if (debug) then
         write(unit=ori_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
              'No.', m, 'Variable: ', trim(vbt_name), &
              'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

         call da_get_var_2d_real_cdf( wrf_bdy_file, trim(vbt_name), tend2d, &
                                   dims(1), dims(2), 2, debug)

         write(unit=ori_unit, fmt='(a, 10i12)') &
              ' old ', (i, i=1,dims(2))
         do j=1,dims(1)
            write(unit=ori_unit, fmt='(i4, 1x, 10e20.7)') &
                  j, (tend2d(j,i), i=1,dims(2))
         end do
      end if

      ! calculate variable at second time level
      select case(m)
      case (1) ;             ! West boundary
         do l=1,dims(2)
            do j=1,dims(1)
               if (time_level < 3) &
                  scnd2d(j,l)=frst2d(j,l)+tend2d(j,l)*bdyfrq
               frst2d(j,l)=mu(l,j)
            end do
         end do
      case (2) ;             ! East boundary
         do l=1,dims(2)
            do j=1,dims(1)
               if (time_level < 3) &
                  scnd2d(j,l)=frst2d(j,l)+tend2d(j,l)*bdyfrq
               frst2d(j,l)=mu(east_end-l,j)
            end do
         end do
      case (3) ;             ! South boundary
         do l=1,dims(2)
            do i=1,dims(1)
               if (time_level < 3) &
                  scnd2d(i,l)=frst2d(i,l)+tend2d(i,l)*bdyfrq
               frst2d(i,l)=mu(i,l)
            end do
         end do
      case (4) ;             ! North boundary
         do l=1,dims(2)
            do i=1,dims(1)
               if (time_level < 3) &
                  scnd2d(i,l)=frst2d(i,l)+tend2d(i,l)*bdyfrq
               frst2d(i,l)=mu(i,north_end-l)
            end do
         end do
      case default ;
         write(unit=stdout,fmt=*) 'It is impossible here. mu, m=', m
      end select

      ! calculate new tendancy
      do l=1,dims(2)
         do i=1,dims(1)
            tend2d(i,l)=(scnd2d(i,l)-frst2d(i,l))/bdyfrq
         end do
      end do

      if (debug) then
         write(unit=new_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
              'No.', m, 'Variable: ', trim(vbt_name), &
              'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

         write(unit=new_unit, fmt='(a, 10i12)') &
              ' new ', (i, i=1,dims(2))

         do j=1,dims(1)
            write(unit=new_unit, fmt='(i4, 1x, 10e20.7)') &
                  j, (tend2d(j,i), i=1,dims(2))
         end do
      end if

      ! output new variable at first time level
      call da_put_var_2d_real_cdf( wrf_bdy_file, trim(var_name), frst2d, &
                                dims(1), dims(2), 2, debug)
      ! output new tendancy
      call da_put_var_2d_real_cdf( wrf_bdy_file, trim(vbt_name), tend2d, &
                                dims(1), dims(2), 2, debug)

      deallocate(frst2d)
      deallocate(scnd2d)
      deallocate(tend2d)
   end do

   !---------------------------------------------------------------------
   ! For 3D variables

   ! Get U
   call da_get_dims_cdf( da_file_02, 'U', dims, ndims, debug)

   ! call da_get_att_cdf( da_file_02, 'U', debug)

   allocate(u(dims(1), dims(2), dims(3)))

   ids=1
   ide=dims(1)-1
   jds=1
   jde=dims(2)
   kds=1
   kde=dims(3)

   call da_get_var_3d_real_cdf( da_file_02, 'U', u, &
                             dims(1), dims(2), dims(3), 1, debug)

   ! Get V
   call da_get_dims_cdf( da_file_02, 'V', dims, ndims, debug)

   allocate(v(dims(1), dims(2), dims(3)))

   call da_get_var_3d_real_cdf( da_file_02, 'V', v, &
                             dims(1), dims(2), dims(3), 1, debug)

   if (debug) then
      write(unit=stdout, fmt='(a,e20.12,4x)') &
           'Before couple Sample u=', u(dims(1)/2,dims(2)/2,dims(3)/2), &
           'Before couple Sample v=', v(dims(1)/2,dims(2)/2,dims(3)/2)
   end if

   !---------------------------------------------------------------------
   ! Couple u, v.
   call da_couple_uv ( u, v, mu, mub, msfu, msfv, c1h, c2h, ids, ide, jds, jde, kds, kde)

   if (debug) then
      write(unit=stdout, fmt='(a,e20.12,4x)') &
           'After  couple Sample u=', u(dims(1)/2,dims(2)/2,dims(3)/2), &
           'After  couple Sample v=', v(dims(1)/2,dims(2)/2,dims(3)/2)
   end if

   !---------------------------------------------------------------------
   !For 3D variables

   do n=1,num3d
      write(unit=stdout, fmt='(a, i3, 2a)') 'Processing: var3d(', n, ')=', trim(var3d(n))

      call da_get_dims_cdf( da_file_02, trim(var3d(n)), dims, ndims, debug)

      allocate(full3d(dims(1), dims(2), dims(3)))

      east_end=dims(1)+1
      north_end=dims(2)+1

      select case(trim(var3d(n)))
      case ('U') ;           ! U
         ! var_pref='R' // trim(var3d(n))
         var_pref=trim(var3d(n))
         full3d(:,:,:)=u(:,:,:)
      case ('V') ;           ! V
         ! var_pref='R' // trim(var3d(n))
         var_pref=trim(var3d(n))
         full3d(:,:,:)=v(:,:,:)
      case ('W') ;
         ! var_pref = 'R' // trim(var3d(n))
         var_pref = trim(var3d(n))

         call da_get_var_3d_real_cdf( da_file_02, trim(var3d(n)), &
            full3d, dims(1), dims(2), dims(3), 1, debug)

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'Before couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if

         do k=1,dims(3)
            do j=1,dims(2)
               do i=1,dims(1)
                  full3d(i,j,k)=full3d(i,j,k)*(c1f(k)*(mu(i,j)+mub(i,j))+c2f(k))/msfm(i,j)
               end do
            end do
         end do

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'After  couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if
      case ('T', 'PH') ;
         var_pref=trim(var3d(n))

         if ( use_theta_m > 0 .and. trim(var3d(n)) == 'T' ) then
           call da_get_var_3d_real_cdf( da_file_02, 'THM', &
              full3d, dims(1), dims(2), dims(3), 1, debug)
         else
           call da_get_var_3d_real_cdf( da_file_02, trim(var3d(n)), &
              full3d, dims(1), dims(2), dims(3), 1, debug)
         end if

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'Before couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if

         if ( dims(3) == nlevf ) then
            ! applying c1f and c2f for mu
            do k=1,dims(3)
               do j=1,dims(2)
                  do i=1,dims(1)
                     full3d(i,j,k)=full3d(i,j,k)*(c1f(k)*(mu(i,j)+mub(i,j))+c2f(k))
                  end do
               end do
            end do
         else if ( dims(3) == nlevh ) then
            ! applying c1h and c2h for mu
            do k=1,dims(3)
               do j=1,dims(2)
                  do i=1,dims(1)
                     full3d(i,j,k)=full3d(i,j,k)*(c1h(k)*(mu(i,j)+mub(i,j))+c2h(k))
                  end do
               end do
            end do
         else
            write(unit=stdout,fmt=*) 'Error finding matched dimensions.'
            stop
         end if

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'After  couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if
      case ('QVAPOR', 'QCLOUD', 'QRAIN', 'QICE', 'QSNOW', 'QGRAUP') ;
         ! var_pref='R' // var3d(n)(1:2)
         ! var_pref=var3d(n)(1:2)
         var_pref=var3d(n)

         call da_get_var_3d_real_cdf( da_file_02, trim(var3d(n)), &
            full3d, dims(1), dims(2), dims(3), 1, debug)

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'Before couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if

         do k=1,dims(3)
            do j=1,dims(2)
               do i=1,dims(1)
                  full3d(i,j,k)=full3d(i,j,k)*(c1h(k)*(mu(i,j)+mub(i,j))+c2h(k))
               end do
            end do
         end do

         if (debug) then
            write(unit=stdout, fmt='(3a,e20.12,4x)') &
                 'After  couple Sample ', trim(var3d(n)), &
                 '=', full3d(dims(1)/2,dims(2)/2,dims(3)/2)
         end if
      case default ;
         write(unit=stdout,fmt=*) 'It is impossible here. var3d(', n, ')=', trim(var3d(n))
      end select

      do m=1,4
         var_name=trim(var_pref) // trim(bdyname(m))
         vbt_name=trim(var_pref) // trim(tenname(m))

         write(unit=stdout, fmt='(a, i3, 2a)') &
            'Processing: bdyname(', m, ')=', trim(var_name)

         call da_get_dims_cdf( wrf_bdy_file, trim(var_name), dims, ndims, debug)

         allocate(frst3d(dims(1), dims(2), dims(3)))
         allocate(scnd3d(dims(1), dims(2), dims(3)))
         allocate(tend3d(dims(1), dims(2), dims(3)))

         ! Get variable at second time level
         if (time_level > 2) then
            call da_get_var_3d_real_cdf( wrf_bdy_file, trim(var_name), scnd3d, &
                                      dims(1), dims(2), dims(3), 3, debug)
         else
            call da_get_var_3d_real_cdf( wrf_bdy_file, trim(var_name), frst3d, &
                                      dims(1), dims(2), dims(3), 2, debug)
            call da_get_var_3d_real_cdf( wrf_bdy_file, trim(vbt_name), tend3d, &
                                      dims(1), dims(2), dims(3), 2, debug)
         end if

         if (debug) then
            write(unit=ori_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
                 'No.', m, 'Variable: ', trim(vbt_name), &
                 'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

            call da_get_var_3d_real_cdf( wrf_bdy_file, trim(vbt_name), tend3d, &
                                      dims(1), dims(2), dims(3), 2, debug)

            write(unit=ori_unit, fmt='(a, 10i12)') &
                 ' old ', (i, i=1,dims(3))
            do j=1,dims(1)
               write(unit=ori_unit, fmt='(i4, 1x, 10e20.7)') &
                     j, (tend3d(j,dims(2)/2,i), i=1,dims(3))
            end do
         end if

         select case(trim(bdyname(m)))
         case ('_BXS') ;             ! West boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do j=1,dims(1)
               if (time_level < 3) &
               scnd3d(j,k,l)=frst3d(j,k,l)+tend3d(j,k,l)*bdyfrq
               frst3d(j,k,l)=full3d(l,j,k)
            end do
            end do
            end do
         case ('_BXE') ;             ! East boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do j=1,dims(1)
               if (time_level < 3) &
               scnd3d(j,k,l)=frst3d(j,k,l)+tend3d(j,k,l)*bdyfrq
               frst3d(j,k,l)=full3d(east_end-l,j,k)
            end do
            end do
            end do
         case ('_BYS') ;             ! South boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do i=1,dims(1)
               if (time_level < 3) &
               scnd3d(i,k,l)=frst3d(i,k,l)+tend3d(i,k,l)*bdyfrq
               frst3d(i,k,l)=full3d(i,l,k)
            end do
            end do
            end do
         case ('_BYE') ;             ! North boundary
            do l=1,dims(3)
            do k=1,dims(2)
            do i=1,dims(1)
               if (time_level < 3) &
               scnd3d(i,k,l)=frst3d(i,k,l)+tend3d(i,k,l)*bdyfrq
               frst3d(i,k,l)=full3d(i,north_end-l,k)
            end do
            end do
            end do
         case default ;
            write(unit=stdout,fmt=*) 'It is impossible here.'
            write(unit=stdout,fmt=*) 'bdyname(', m, ')=', trim(bdyname(m))
            stop
         end select

         write(unit=stdout, fmt='(a, i3, 2a)') &
            'cal. tend: bdyname(', m, ')=', trim(vbt_name)

         ! calculate new tendancy
         do l=1,dims(3)
            do k=1,dims(2)
               do i=1,dims(1)
                  tend3d(i,k,l)=(scnd3d(i,k,l)-frst3d(i,k,l))/bdyfrq
               end do
            end do
         end do

         if (debug) then
            write(unit=new_unit, fmt='(a,i2,2x,2a/a,i2,2x,a,4i6)') &
                 'No.', m, 'Variable: ', trim(vbt_name), &
                 'ndims=', ndims, 'dims=', (dims(i), i=1,ndims)

            write(unit=new_unit, fmt='(a, 10i12)') &
                 ' new ', (i, i=1,dims(3))

            do j=1,dims(1)
               write(unit=new_unit, fmt='(i4, 1x, 10e20.7)') &
                     j, (tend3d(j,dims(2)/2,i), i=1,dims(3))
            end do
         end if

         ! output new variable at first time level
         call da_put_var_3d_real_cdf( wrf_bdy_file, trim(var_name), frst3d, &
                                dims(1), dims(2), dims(3), 2, debug)
         call da_put_var_3d_real_cdf( wrf_bdy_file, trim(vbt_name), tend3d, &
                                   dims(1), dims(2), dims(3), 2, debug)

         deallocate(frst3d)
         deallocate(scnd3d)
         deallocate(tend3d)
      end do

      deallocate(full3d)
   end do

   deallocate(mu)
   deallocate(u)
   deallocate(v)

   end if ! end of update second time level LBC for var4d_lbc

   deallocate(mub)
   deallocate(msfu)
   deallocate(msfv)
   deallocate(times)
   deallocate(thisbdytime)
   deallocate(nextbdytime)

 end if ! end if update_lateral_bdy

 deallocate ( c1f )
 deallocate ( c2f )
 deallocate ( c1h )
 deallocate ( c2h )

 write(unit=stdout,fmt=*) &
    '=================================================================='
 if ( update_lateral_bdy ) then
    write(unit=stdout,fmt=*) 'Lateral boundary tendency updated.'
 end if
 if ( update_low_bdy ) then
    write(unit=stdout,fmt=*) 'Low boundary updated with wrf_input fields.'
 end if
 if ( update_lsm ) then
    write(unit=stdout,fmt=*) 'LSM variables updated with wrf_input fields.'
 end if

   if (io_status == 0) &
      write (unit=stdout,fmt=*) "*** Update_bc completed successfully ***"

end program da_update_bc


      FUNCTION K79R(J,M,K,L,R, JA)
C BY DENNIS AMBUEHL AND KEVIN HICKEY
C FROM CARDS BY JM 3/16/79
      DIMENSION JBACK(5)
C      COOPERATES IF OPPONENT COOPERATED ON MAJORITY OF LAST PLAYS
      k79r=ja    ! Added 7/27/93 to report own old value
      IF (M.EQ.1) GO TO 3000
      IF (M.LT.6) GO TO 4000
      I1 = 0
      DO 1500 I2 = 1,5
 1500 I1 = I1 + JBACK(I2)
      IF (I1.LT.3) GO TO 1000
      K79R = 1
      GO TO 2000
 3000 DO 2500 I2 = 1,5
 2500 JBACK(I2) = 0
 1000 K79R = 0
 2000 DO 3500 I2 = 1,4
 3500 JBACK(I2) = JBACK(I2 + 1)
      JBACK(5) = J
      RETURN
 4000 K79R = J
      GO TO 2000
      END


        !COMPILER-GENERATED INTERFACE MODULE: Fri May 22 16:58:52 2020
        ! This source file is for reference only and may not completely
        ! represent the generated interface used by the compiler.
        MODULE IS_IN_CONVEX_QUADRILATERAL__genmod
          INTERFACE
            SUBROUTINE IS_IN_CONVEX_QUADRILATERAL(ELMNT_COORDS,X_COORD, &
     &Z_COORD,IS_IN)
              REAL(KIND=8) :: ELMNT_COORDS(2,4)
              REAL(KIND=8), INTENT(IN) :: X_COORD
              REAL(KIND=8), INTENT(IN) :: Z_COORD
              LOGICAL(KIND=4), INTENT(OUT) :: IS_IN
            END SUBROUTINE IS_IN_CONVEX_QUADRILATERAL
          END INTERFACE
        END MODULE IS_IN_CONVEX_QUADRILATERAL__genmod


      subroutine  normal  ( iflg,fdum2 )
!***********************************************************************
!  Copyright, 2004,  The  Regents  of the  University of California.
!  This program was prepared by the Regents of the University of
!  California at Los Alamos National Laboratory (the University) under
!  contract No. W-7405-ENG-36 with the U.S. Department of Energy (DOE).
!  All rights in the program are reserved by the DOE and the University.
!  Permission is granted to the public to copy and use this software
!  without charge, provided that this Notice and any statement of
!  authorship are reproduced on all copies. Neither the U.S. Government
!  nor the University makes any warranty, express or implied, or
!  assumes any liability or responsibility for the use of this software.
C***********************************************************************
CD1
CD1  PURPOSE
CD1
CD1  This subroutine normalizes the matrix equations and returns the
CD1  sum of the residuals.
CD1
C***********************************************************************
CD2
CD2  REVISION HISTORY
CD2
CD2 $Log:   /pvcs.config/fehm90/src/normal.f_a  $
!D2
!D2    Rev 2.5   06 Jan 2004 10:43:32   pvcs
!D2 FEHM Version 2.21, STN 10086-2.21-00, Qualified October 2003
!D2
!D2    Rev 2.4   29 Jan 2003 09:10:42   pvcs
!D2 FEHM Version 2.20, STN 10086-2.20-00
!D2
!D2    Rev 2.3   14 Nov 2001 13:11:14   pvcs
!D2 FEHM Version 2.12, STN 10086-2.12-00
!D2
!D2    Rev 2.2   06 Jun 2001 13:25:32   pvcs
!D2 FEHM Version 2.11, STN 10086-2.11-00
!D2
!D2    Rev 2.1   30 Nov 2000 12:05:28   pvcs
!D2 FEHM Version 2.10, STN 10086-2.10-00
!D2
!D2    Rev 2.0   Fri May 07 14:43:54 1999   pvcs
!D2 FEHM Version 2.0, SC-194 (Fortran 90)
CD2
CD2    Rev 1.4   Wed Jan 10 14:52:24 1996   hend
CD2 Added Prolog
CD2
CD2    Rev 1.3   11/16/95 10:29:18   llt
CD2 min function doesn't work inside a statement function on the ibm.
CD2
CD2    Rev 1.2   09/29/95 16:11:10   llt
CD2 added small number on dividing -- was dividing by zerol
CD2 getting min of fadn & fbdn function -- was infinity
CD2
CD2    Rev 1.1   03/18/94 15:59:40   gaz
CD2 Added solve_new and cleaned up memory management.
CD2
CD2    Rev 1.0   01/20/94 10:25:58   pvcs
CD2 original version in process of being certified
CD2
c version FEHM5.1J changes
c 16-july-91
c defered zeroing out dfmp(i) etc to geneq1 (took it out here
c 16-july-91
c set tollr=tmch*0.1 if appropriate
c 23-july-91
c zeroed out appropriate derivatives in gensl1(4) for zero porosity
c 19-august-91
c changed equivalence statements to reflect smaller common/fcc/
c 11-nov-91
c changed gensl1 to reflect symmetry in assembly(geneq1)
c 12-nov-91
c changed gensl4 to have changes made in gensl1
c 13-nov-91
c changed gensl3 to reflect changes in geneq3
c 15-nov-91
c changed nr3 to nrhs(3) in gensl4
c 16-nov-91
c changed nsizea=nmat(8).. to =nmat(9)..
c 29-nov-91
c changed to generic intrisic functions
c 23-dec-91
c cleaned up some coding in rdof routines
c added some new code to rd2dof
c 24-dec-91
c deleted do 40 loop(set sol1,sol2=0)
c 30-dec-91
c still playing with residual adjustment in rd2dof
c added other call to solve in rd2dof
c put in decision making ability in rd2dof
c 2-jan-92
c put changes in rd2dof ,do loops before 2nd call to solve
c 13-jan-92
c more changes to rd2dof :iteration on back subafter solve
c 16-jan-92
c started modifying rd3dof to be like rd2dof
c modified equivalence statement in gensl4
c 18-jan-92
c some mods of rd3dof
c put returns before call to solve if residuals are small(rd2dof,rd3dof)
c 26-feb-92
c modified coding near call to geneq3 to position equations correctly
c actually changed call to geneq3 to geneq1 in gensl1 and genslc
c 2-feb-93
c took out 1.0e-20 in fdum2 sum ,replace with tollah
c 11-feb-93
c added subroutine normal_uc for uncoupled normalization
c 3-apr-93
c added variable switching in gensl4 (p,s,t) to (p,t,s)
c 7-apr-93
c took out bpc in gensl4
c 9-apr-93
c put in switch routines for equation ordering
c 12-apr-93
c put nmat stuff in normal ,got rid of nb
c 12-april-93
c delete code for iflg=1 from normal(irdof?)
c 27-apr-93
c added islord=-1 option
c changed call ti switchb,changed gensl1,gensl2
c 7-may-93 llt
c equivalences changed to pointers
c 7-may-93 llt
c replaced gotos embedded in code with a goto at end of subroutine
c 8-june-93
c fixed call to rd3dof
C***********************************************************************
CD3
CD3  REQUIREMENTS TRACEABILITY
CD3
CD3  3.4.2     Solve Nonlinear Equation at Each Time Step
CD3
C**********************************************************************
CD4
CD4  SPECIAL COMMENTS AND REFERENCES
CD4
C**********************************************************************

      use combi
      use comci
      use comdi
      use comei
      use comfi
      use comgi
      use comhi
      use davidi
      use comdti
      use comai

      implicit none
      integer i, i1, i2, idgm, iflg, ikd, ilq
      integer j, jm, neq2, neqp1
      real*8  a1, a2, a3, a4, a5, ali, ali3, alm, alm3
      real*8  a11, a12, a13, a21, a22, a23, a31, a32, a33
      real*8  an11, an12, an21, an22
      real*8  b1, b2, b3, det
      real*8  fad, fadn, fbd, fbdn, fcd, fcdn, fdm2i, fdum2
      real*8  p1, p2, p3, p4, p5, p6, p7, p8, p9, p11, p12, p21, p22
      real*8  tollah
      parameter( tollah=1.d-40)

c**** linear algebra ****
      alm (a1,a2,b1,b2)       =       a1*b1+a2*b2
      ali (a1,a2,a3,a4,b1)    =  b1/( (a1*a4-a2*a3) + 1e-30 )
      ali3(a1,a2,a3,a4,a5)    =     ( a1*a2-a3*a4       )/a5
      alm3(a1,a2,a3,b1,b2,b3) =       a1*b1+a2*b2+a3*b3

      neqp1  =  neq+1
      if ( iflg .eq. 0 )  then

c**** heat and mass transfer solution ****
         fdum2  =  0.0
         do i=1,neq
            i1     =  nelm(i  )+1
            i2     =  nelm(i+1)
            idgm   =  nelmdg(i)-neqp1
            a11    =  a(idgm+nmat(1))
            a12    =  a(idgm+nmat(2))
            a21    =  a(idgm+nmat(3))
            a22    =  a(idgm+nmat(4))

            p11    =  ali( a11,a12,a21,a22,a22 )
            p12    = -ali( a11,a12,a21,a22,a12 )
            p21    = -ali( a11,a12,a21,a22,a21 )
            p22    =  ali( a11,a12,a21,a22,a11 )

            fad    =  bp(i+nrhs(1))
            fbd    =  bp(i+nrhs(2))
            fadn   =  alm( p11,p12,fad,fbd )
            fbdn   =  alm( p21,p22,fad,fbd )

            bp(i+nrhs(1)) =  fadn
            bp(i+nrhs(2)) =  fbdn

            do j=i1,i2
               jm =  j-neqp1
               if (jm .eq. idgm )  then
                  a(jm+nmat(1)) =  1.0
                  a(jm+nmat(2)) =  0.0
                  a(jm+nmat(3)) =  0.0
                  a(jm+nmat(4)) =  1.0
               else
                  a11    =  a(jm+nmat(1))
                  a12    =  a(jm+nmat(2))
                  a21    =  a(jm+nmat(3))
                  a22    =  a(jm+nmat(4))
                  an11   =  alm( p11,p12,a11,a21 )
                  an12   =  alm( p11,p12,a12,a22 )
                  an21   =  alm( p21,p22,a11,a21 )
                  an22   =  alm( p21,p22,a12,a22 )
                  a(jm+nmat(1)) =  an11
                  a(jm+nmat(2)) =  an12
                  a(jm+nmat(3)) =  an21
                  a(jm+nmat(4)) =  an22
               endif
            enddo
            fdum2  =  fdum2+fadn**2+fbdn**2
         enddo
      endif
      if ( iflg .ne .0 )  then
c**** heat , mass , and noncondensible present - full jacobian ****
         neq2   =  neq*2
         fdum2  =  0.0
         do i=1,neq
            i1     =  nelm(i  )+1
            i2     =  nelm(i+1)
            idgm   =  nelmdg(i)-neqp1
            a11    =  a(idgm+nmat(1))
            a12    =  a(idgm+nmat(2))
            a13    =  a(idgm+nmat(3))
            a21    =  a(idgm+nmat(4))
            a22    =  a(idgm+nmat(5))
            a23    =  a(idgm+nmat(6))
            a31    =  a(idgm+nmat(7))
            a32    =  a(idgm+nmat(8))
            a33    =  a(idgm+nmat(9))
            fad    =  bp(i+nrhs(1))
            fbd    =  bp(i+nrhs(2))
            fcd    =  bp(i+nrhs(3))
            det    =   a11*a22*a33+a12*a23*a31+a13*a21*a32
     *           -a13*a22*a31-a11*a23*a32-a12*a21*a33
            p1     =  ali3( a22,a33,a23,a32,det )
            p2     =  ali3( a13,a32,a12,a33,det )
            p3     =  ali3( a12,a23,a13,a22,det )
            p4     =  ali3( a23,a31,a21,a33,det )
            p5     =  ali3( a11,a33,a13,a31,det )
            p6     =  ali3( a13,a21,a11,a23,det )
            p7     =  ali3( a21,a32,a22,a31,det )
            p8     =  ali3( a12,a31,a11,a32,det )
            p9     =  ali3( a11,a22,a12,a21,det )
            fadn   =  alm3( p1,p2,p3,fad,fbd,fcd )
            fbdn   =  alm3( p4,p5,p6,fad,fbd,fcd )
            fcdn   =  alm3( p7,p8,p9,fad,fbd,fcd )
            fdm2i  =  fadn**2+fbdn**2+fcdn**2+tollah
            bp(i+nrhs(1)) = fadn
            bp(i+nrhs(2)) = fbdn
            bp(i+nrhs(3)) = fcdn
            do ikd=i1,i2
               ilq    =  ikd-neqp1
               if (ilq .eq. idgm )  then
                  a(ilq+nmat(1)) =  1.0
                  a(ilq+nmat(2)) =  0.0
                  a(ilq+nmat(3)) =  0.0
                  a(ilq+nmat(4)) =  0.0
                  a(ilq+nmat(5)) =  1.0
                  a(ilq+nmat(6)) =  0.0
                  a(ilq+nmat(7)) =  0.0
                  a(ilq+nmat(8)) =  0.0
                  a(ilq+nmat(9)) =  1.0
               else
                  a11    =  a(ilq+nmat(1))
                  a12    =  a(ilq+nmat(2))
                  a13    =  a(ilq+nmat(3))
                  a21    =  a(ilq+nmat(4))
                  a22    =  a(ilq+nmat(5))
                  a23    =  a(ilq+nmat(6))
                  a31    =  a(ilq+nmat(7))
                  a32    =  a(ilq+nmat(8))
                  a33    =  a(ilq+nmat(9))
                  a(ilq+nmat(1)) =  alm3(p1,p2,p3,a11,a21,a31)
                  a(ilq+nmat(2)) =  alm3(p1,p2,p3,a12,a22,a32)
                  a(ilq+nmat(3)) =  alm3(p1,p2,p3,a13,a23,a33)
                  a(ilq+nmat(4)) =  alm3(p4,p5,p6,a11,a21,a31)
                  a(ilq+nmat(5)) =  alm3(p4,p5,p6,a12,a22,a32)
                  a(ilq+nmat(6)) =  alm3(p4,p5,p6,a13,a23,a33)
                  a(ilq+nmat(7)) =  alm3(p7,p8,p9,a11,a21,a31)
                  a(ilq+nmat(8)) =  alm3(p7,p8,p9,a12,a22,a32)
                  a(ilq+nmat(9)) =  alm3(p7,p8,p9,a13,a23,a33)
               endif
            enddo
            fdum2 =  fdum2+fdm2i
         enddo
      endif

      return
      end


      SUBROUTINE INITER_DEM
C***********************************************************************
C*               INITER_DEM Module of AERMAP Terrain Preprocessor
C*
C*       PURPOSE: Read Terrain Data from Raw DEM Data Files and Write Out
C*                the Data to Direct Access Binary Terrain Data Files.
C*                Also Create Record Index Files
C*
C*
C*       PROGRAMMER: Jayant Hardikar, Roger Brode
C*
C*       DATE:    September 29, 1995
C*
C*       MODIFIED: February 9, 2009
C*
C*                Modified output format for UTM Zone to I3 to
C*                accommodate Southern Hemisphere applications,
C*                since Southern zones are negative.  Also
C*                adjusted output format for XBASE and YBASE
C*                to accommodate double precision values.
C*                Adjusted XBASE (longitude) for LAT files to
C*                use negative for west longitude.
C*                Modified to account for no-DOMAIN option.
C*                Also modified handling of missing elevation
C*                data and elevation of local datum (LOCEL).
C*                Added information on direct access files to
C*                the DOMDETAIL.OUT debug file.
C*                Roger W. Brode, U.S. EPA, OAQPS, AQMG
C*
C*       MODIFIED: December 7, 2006
C*
C*                Corrected several problems related to NAD conversion
C*                process, procedure for optimizing critical hill height
C*                calculations for neighboring DEM files, and other issues.
C*                See header comments in AERMAP.FOR source file and
C*                AERMAP MCB#1 for more details.
C*                Roger W. Brode, U.S. EPA, OAQPS, AQMG
C*
C*       INPUTS:  Raw Terrain Data (DEM) Files
C*
C*       OUTPUTS: Direct Access Binary Terrain Files
C*
C*       CALLED FROM:   MAIN
C***********************************************************************

C*    Variable Declarations
      USE MAIN1

      IMPLICIT NONE

      SAVE

      CHARACTER*12 MODNAM

      LOGICAL NEWPRO
      DOUBLE PRECISION XNODEI,YNODEI
      DOUBLE PRECISION NADFLG
      DOUBLE PRECISION ARGE, ARGN, XARG, YARG
      DOUBLE PRECISION XBUTM, YBUTM, XNUTM, YNUTM
      DOUBLE PRECISION XBLON, YBLAT
      INTEGER IPROF, J, K, L, M, IERR, INOD

      INTEGER, ALLOCATABLE :: NUMNOD(:)

      INTEGER NSTART, N, JRECRD, RC, ZMINSHFT, ZMAXSHFT
      INTEGER IZONE, ISPHERE

      logical   :: L_FirstProf  ! flg to indicate first profile within domain

      DOUBLE PRECISION :: ELV

      MODNAM = 'INITER_DEM'

      L_FirstProf = .true.

      XBUTM = 0.0D0
      YBUTM = 0.0D0
      XNUTM = 0.0D0
      YNUTM = 0.0D0
      XBLON = 0.0D0
      YBLAT = 0.0D0

C*    Loop Over Terrain Files
      DEMLOOP: DO IDEM = 1, NUMDEM

C*       Assign J=IDEM for READ Statements
         J = IDEM

C*       Initialize Some Variables
         NUMPRF(IDEM) = 0

C*       Open the DEM File * Read Total Number of Elevation
C*       Profiles etc.
         REWIND (IDMUNT(IDEM))

         IF (FT(J) .NE. 1) THEN
C*          Open as standard formatted file
            OPEN(UNIT = IDMUNT(IDEM), FILE= DEMFIL(IDEM), ERR = 95)
            READ (IDMUNT(IDEM),51, ERR=97)
     &       MAPN(J), FREEF(J), FILR1(J), PROCODE(J), FILR2(J),
     &       SECTNL(J), MCTR(J), DEMLVL(J), ELEVPAT(J),
     &       IPLAN(J), IZO(J), (MPROJ(J,L), L = 1,15), CUNIT(J),
     &       ELUNIT(J), SIDZ(J), ((DMCNR(J,L,M),L=1,2),M=1,4),
     &       ELEVMN(J), ELEVMX(J), CNTRC(J),ACCUC(J),
     &       DXM(J), DYM(J),DCI(J), NROW(J), NPROF(J), LPRIM(J),
     &       LPINT(J), SPRIM(J), SPINT(J),
     &       DDATE(J), DINSP(J), INSPF(J), DVALD(J), SUSF(J),
     &       VDAT(J), NADD(J), EDITN(J), PVOID(J)
         ELSE
C*          For FT(J) = 1 (no record delimiters) open as direct access file
            OPEN(UNIT = IDMUNT(IDEM), FILE= DEMFIL(IDEM),
     &         RECL = 1024,
     &         ACCESS = 'DIRECT',
     &         FORM ='FORMATTED',
     &         ERR = 95)
            READ (IDMUNT(IDEM), FMT=51, REC = 1, ERR=97)
     &       MAPN(J), FREEF(J), FILR1(J), PROCODE(J), FILR2(J),
     &       SECTNL(J), MCTR(J), DEMLVL(J), ELEVPAT(J),
     &       IPLAN(J), IZO(J), (MPROJ(J,L), L = 1,15), CUNIT(J),
     &       ELUNIT(J), SIDZ(J), ((DMCNR(J,L,M),L=1,2),M=1,4),
     &       ELEVMN(J), ELEVMX(J), CNTRC(J), ACCUC(J),
     &       DXM(J),DYM(J),DCI(J), NROW(J), NPROF(J), LPRIM(J),
     &       LPINT(J), SPRIM(J), SPINT(J),
     &       DDATE(J), DINSP(J), INSPF(J), DVALD(J), SUSF(J),
     &       VDAT(J), NADD(J), EDITN(J), PVOID(J)
         END IF

  51     FORMAT(2A40, A55, 2A1, A3, A4, 2I6,
     &          2I6, 15D24.15, I6,
     &          2I6, 4(2D24.15), 2D24.15, D24.15,
     &          I6, 2E12.6, E12.6, 2I6, 2(I5,I1),
     &          2I4, A1, I1, I2,
     &          2I2, 2I4)

C*       Assign DEM zone from Record A to IZOND(NDEM) array
         IF (IZO(IDEM) .NE. 0) THEN
            IZOND(IDEM) = IZO(IDEM)
         END IF

C*       Open Temporary Direct Access Terrain Files and Index Files
         OPEN (IDRUNT(IDEM),FILE=DIRFIL(IDEM),
     &         ACCESS='DIRECT',RECL=LREC_DIR)
         OPEN (IDXUNT(IDEM),FILE=IDXFIL(IDEM))

C*       For Each Profile in the DEM File
         RC = 1

C*       Check for blank (0) NADD from DEM Record Type A
C*       This was already done in CHKADJ based on DEMCHK read,
C*       but needs to be checked again here for new read.
         IF (NADD(IDEM) .EQ. 0 .AND. IPLAN(IDEM) .EQ. 0) THEN
C*          Assume WGS72 for LAT files
            NADD(IDEM) = 2
         ELSE IF (NADD(IDEM) .EQ. 0 .AND. IPLAN(IDEM) .EQ. 1) THEN
C*          Assum NAD27 for UTM files
            NADD(IDEM) = 1
         END IF

         IF (.NOT. GOTDOMFLG) THEN
C*          No user-specified domain; skip domain shift calcs
            XDMNSHFT = 0.0D0
            YDMNSHFT = 0.0D0
            XDMXSHFT = 0.0D0
            YDMXSHFT = 0.0D0
            GO TO 777
         END IF
C*
C*       Determine whether to apply NAD shift to Domain
         IF (NADA .EQ. 0 .OR. NADA .EQ. NADD(IDEM)) THEN

            NADFLG = 0.0D0                ! No NAD shift needed

         ELSE IF( (NADA.EQ.1    .OR.  NADA.GE.5) .AND.
     &            (NADD(IDEM).GE.2 .AND. NADD(IDEM).LE.4) )THEN

            NADFLG = 1.0D0                ! Include NAD shift

         ELSE IF( (NADA.GE.2    .AND. NADA.LE.4) .AND.
     &            (NADD(IDEM).EQ.1 .OR.  NADD(IDEM).GE.5) )THEN

            NADFLG = 1.0D0                ! Include NAD shift

         ELSE

            NADFLG = 0.0D0                ! No NAD shift needed

         END IF

C*       Apply NAD shift if necessary, based on type of DEM data
         IF (TYPDEM .EQ. 'LAT') THEN
C*          Apply datum shift in arc-seconds for LAT files
            XDMNSHFT = DOMLL(2,1) + (XDMNDIFS*NADFLG)
            YDMNSHFT = DOMLL(1,1) + (YDMNDIFS*NADFLG)
            XDMXSHFT = DOMLL(2,3) + (XDMXDIFS*NADFLG)
            YDMXSHFT = DOMLL(1,3) + (YDMXDIFS*NADFLG)
         ELSE IF (TYPDEM .EQ. 'UTM') THEN
C*          Apply total shift in meters for UTM files
            XDMNSHFT = XDMIN + (XDMNDIFM*NADFLG)
            YDMNSHFT = YDMIN + (YDMNDIFM*NADFLG)
            XDMXSHFT = XDMAX + (XDMXDIFM*NADFLG)
            YDMXSHFT = YDMAX + (YDMXDIFM*NADFLG)
            IF (NADFLG .EQ. 0.0D0) THEN
C*             Use original domain zones if no NAD shift
               ZMINSHFT = ZONMIN
               ZMAXSHFT = ZONMAX
            ELSE
C*             Use UTM zones based on shifted domain
               ZMINSHFT = ZONMIN_SHFT
               ZMAXSHFT = ZONMAX_SHFT
            END IF
         END IF

C*       Loop through profiles to extract data within domain
C*       for this DEM file:

  777    CONTINUE

C*       Allocate array for number of nodes, NUMNOD(NPROF(IDEM))
C*       First deallocate if needed
         IF (ALLOCATED(NUMNOD)) DEALLOCATE(NUMNOD)
         ALLOCATE (NUMNOD(NPROF(IDEM)))

         DO IPROF = 1, NPROF(IDEM)

C*          Initialize Variables
            NEWPRO = .TRUE.
            XNODEI = 0.0D0
            YNODEI = 0.0D0
            NUMNOD(IPROF) = 0

C*          Read Elevation From Each Profile Record.
            CALL GETPRO(IDEM,IPROF,IERR,RC)

C*          Check for error condition from GETPRO
            IF (IERR .NE. 0) GO TO 999

C*          Check to see if this profile lies between the min
C*          and maximum horizontal coords (LONG or UTMX)
            IF (.NOT. GOTDOMFLG) THEN
C*             No user-specified domain; use all profiles in data files
               GO TO 888
            END IF

            IF (TYPDEM .EQ. 'LAT' .AND. IPLAN(IDEM) .EQ. 0) THEN
C*             DEM/DOMAIN Type matches data file type
               IF (XBASE(IPROF) .LT. XDMNSHFT) THEN
                  CYCLE                        ! Cycle to next profile
               ELSE IF (XBASE(IPROF) .GT. XDMXSHFT) THEN
                  EXIT                         ! Exit profile loop
               END IF
            ELSE IF (TYPDEM .EQ. 'UTM' .AND. IPLAN(IDEM) .EQ. 1) THEN
C*             DEM/DOMAIN Type matches data file type
               IF (ZMINSHFT .EQ. ZMAXSHFT) THEN
                  IF (XBASE(IPROF) .LT. XDMNSHFT) THEN
                     CYCLE                      ! Cycle to next profile
                  ELSE IF (XBASE(IPROF) .GT. XDMXSHFT) THEN
                     EXIT                       ! Exit profile loop
                  END IF
               ELSE IF (IZO(IDEM) .EQ. ZMINSHFT) THEN
                  IF (XBASE(IPROF) .LT. XDMNSHFT) THEN
                     CYCLE                      ! Cycle to next profile
                  END IF
               ELSE IF (IZO(IDEM) .EQ. ZMAXSHFT) THEN
                  IF (XBASE(IPROF) .GT. XDMXSHFT) THEN
                     EXIT                       ! Exit profile loop
                  END IF
               END IF
            ELSE IF (TYPDEM .EQ. 'UTM' .AND. IPLAN(IDEM) .EQ. 0) THEN
C*             DEM/DOMAIN Type does NOT match data file type, convert xbase
C*             Calculate the Coords in UTM relative to NADA ellipsoid

               SELECT CASE (NADD(IDEM))
                 CASE (0)
                   ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                 CASE (2:4)
                   ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                 CASE (1,5:6)
                   ISPHERE = 0   ! UTM/LL conversions based on Clarke 1866 ellipsoid
                 CASE DEFAULT
                   ISPHERE = 4   ! DEFAULT CASE shouldn't occur
                 END SELECT

               ARGE  = XBASE(IPROF)
               ARGN  = YBASE(IPROF)
               IZONE = 0
               XARG  = 0.0D0
               YARG  = 0.0D0
               CALL UTMGEO (555,0,IZONE,XARG,YARG,ARGE,ARGN,ISPHERE)
               XBUTM = XARG
               YBUTM = YARG
               IF (ZMINSHFT .EQ. ZMAXSHFT) THEN
                  IF (XBUTM .LT. XDMNSHFT) THEN
                     CYCLE                     ! Cycle to next profile
                  ELSE IF (XBUTM .GT. XDMXSHFT) THEN
                     EXIT                      ! Exit profile loop
                  END IF
               ELSE IF (IZONE .EQ. ZMINSHFT) THEN
                  IF (XBUTM .LT. XDMNSHFT) THEN
                     CYCLE                     ! Cycle to next profile
                  END IF
               ELSE IF (IZONE .EQ. ZMAXSHFT) THEN
                  IF (XBUTM .GT. XDMXSHFT) THEN
                     EXIT                      ! Exit profile loop
                  END IF
               END IF
            ELSE IF (TYPDEM .EQ. 'LAT' .AND. IPLAN(IDEM) .EQ. 1) THEN
C*             DEM/DOMAIN Type does NOT match data file type, convert xbase
C*             Calculate the Coords in Lat/Lon relative to NADA ellipsoid

               SELECT CASE (NADD(IDEM))
                 CASE (0)
                   ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                 CASE (2:4)
                   ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                 CASE (1,5:6)
                   ISPHERE = 0   ! UTM/LL conversions based on Clarke 1866 ellipsoid
                 CASE DEFAULT
                   ISPHERE = 4   ! DEFAULT CASE shouldn't occur
                 END SELECT

               XARG  = XBASE(IPROF)
               YARG  = YBASE(IPROF)
               IZDUM = 0
               ARGE  = 0.0D0
               ARGN  = 0.0D0
               CALL UTMGEO (333,IZO(IDEM),IZDUM,XARG,YARG,
     &                                          ARGE,ARGN,ISPHERE)
               XBLON = ARGE
               YBLAT = ARGN
               IF (XBLON .LT. XDMNSHFT) THEN
                  CYCLE                        ! Cycle to next profile
               ELSE IF (XBLON .GT. XDMXSHFT) THEN
                  EXIT                         ! Exit profile loop
               END IF
            END IF

  888       CONTINUE

C*          For Each Node in this Profile
            DO INOD = 1, NODES(IPROF)

C*             Determine the Coordinates of this Point (L/L)   ---  CALL GETNOD
               CALL GETNOD(IPROF,INOD)

               IF (.NOT. GOTDOMFLG) THEN
C*                No user-specified domain; use all nodes in each profile

C*                Increment the Number of Nodes in this Profile
C*                Inside the Domain
                  NUMNOD(IPROF) = NUMNOD(IPROF)+1

                  IF (NEWPRO) THEN

C*                   NUMPRF is the number of profiles written to
C*                   the direct access file.
                     NUMPRF(IDEM) = NUMPRF(IDEM) + 1

                     NSTART = INOD
                     NEWPRO = .FALSE.

                     XNODEI = XNODE
                     YNODEI = YNODE

                  END IF

               ELSE

C*                Check to See if This Node Lies Between the Min
C*                and Maximum vertical Coords (LAT or UTMY)

                  IF (TYPDEM .EQ. 'UTM' .AND. IPLAN(IDEM) .EQ. 0) THEN
C*                   DEM/DOMAIN Type does NOT match data file type, convert xbase
C*                   Calculate the Coords in UTM relative to NADA ellipsoid

                     SELECT CASE (NADD(IDEM))
                       CASE (0)
                         ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                       CASE (2:4)
                         ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                       CASE (1,5:6)
                         ISPHERE = 0   ! UTM/LL conversions based on Clarke 1866 ellipsoid
                       CASE DEFAULT
                         ISPHERE = 4   ! DEFAULT CASE shouldn't occur
                       END SELECT

                     ARGE  = XBASE(IPROF)
                     ARGN  = YNODE
                     IZONE = 0
                     XARG  = 0.0D0
                     YARG  = 0.0D0
                     CALL UTMGEO (555,0,IZONE,XARG,YARG,ARGE,ARGN,
     &                                                       ISPHERE)
                     XNUTM = XARG
                     YNUTM = YARG

                  ELSE IF (TYPDEM.EQ.'LAT' .AND. IPLAN(IDEM).EQ.1) THEN
C*                   DEM/DOMAIN Type does NOT match data file type, convert xbase
C*                   Calculate the Coords in Lat/Lon relative to NADA ellipsoid

                     SELECT CASE (NADD(IDEM))
                       CASE (0)
                         ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                       CASE (2:4)
                         ISPHERE = 4   ! UTM/LAT-LONG conversions based on GRS80 ellipsoid
                       CASE (1,5:6)
                         ISPHERE = 0   ! UTM/LL conversions based on Clarke 1866 ellipsoid
                       CASE DEFAULT
                         ISPHERE = 4   ! DEFAULT CASE shouldn't occur
                       END SELECT

                     XARG  = XBASE(IPROF)
                     YARG  = YNODE
                     IZDUM = 0
                     ARGE  = 0.0D0
                     ARGN  = 0.0D0
                     CALL UTMGEO (333,IZO(IDEM),IZDUM,XARG,YARG,
     &                                                ARGE,ARGN,ISPHERE)
                     XBLON = ARGE
                     YBLAT = ARGN
                  END IF

                  IF ((TYPDEM.EQ.'UTM'.AND.IPLAN(IDEM).EQ.0 .AND.
     &                 YNUTM .GE. YDMNSHFT .AND.
     &                 YNUTM .LE. YDMXSHFT) .OR.
     &
     &                (TYPDEM.EQ.'LAT'.AND.IPLAN(IDEM).EQ.1 .AND.
     &                 YBLAT .GE. YDMNSHFT .AND.
     &                 YBLAT .LE. YDMXSHFT) .OR.
     &
     &                (YNODE .GE. YDMNSHFT .AND.
     &                 YNODE .LE. YDMXSHFT) ) THEN

C*                   This node is within the domain

C*                   Increment the Number of Nodes in this Profile
C*                   Inside the Domain
                     NUMNOD(IPROF) = NUMNOD(IPROF)+1

                     IF (NEWPRO) THEN

C*                      NUMPRF is the number of profiles written to
C*                      the direct access file.
                        NUMPRF(IDEM) = NUMPRF(IDEM) + 1

                        NSTART = INOD
                        NEWPRO = .FALSE.

                        XNODEI = XNODE
                        YNODEI = YNODE

                     END IF

                  ELSE IF ((TYPDEM.EQ.'UTM'.AND.IPLAN(IDEM).EQ.0 .AND.
     &                      YNUTM .GT. YDMXSHFT) .OR.
     &
     &                     (TYPDEM.EQ.'LAT'.AND.IPLAN(IDEM).EQ.1 .AND.
     &                      YBLAT .GT. YDMXSHFT) .OR.
     &
     &                     (YNODE .GT. YDMXSHFT) ) THEN

C*                   This node is beyond the domain

                     EXIT                    ! Exit loop on nodes

                  END IF

               END IF

C           End Loop on Nodes
            END DO

C*          If there were any nodes in this profile that were inside
C*          the domain, determine record numbers and write out data
C*          to direct access and index files
            IF (NUMNOD(IPROF) .GT. 0) THEN
C*             Write the baseline coords and number of nodes
C*             in this profile to the master index file
               WRITE (IDXUNT(IDEM),IDXFRM) XNODEI, YNODEI,
     &                NUMNOD(IPROF), IZO(IDEM), MAXEL(IPROF)

C*             For each node in the profile inside the domain
               DO N = 1, NUMNOD(IPROF)

C*                Calculate record number for the node
                  JRECRD = JRECRD + 1

C*                Extract elevation for this node from array
                  ELV = DBLE(ZDEM(NSTART-1+N))

C ---             Convert elevation units and apply other adjustments, except for missing
                  IF (ELV .GT. -9000.0D0) THEN
C*                   Apply vertical resolution factor from header (DCI) to elevations
C                    from file, adjust for elevation of local datum (LOCEL), and
C                    convert from feet to meters, if necessary
                     IF (ELUNIT(IDEM) .EQ. 1) THEN
C                       Convert from feet to meters
                        ELV = ((ELV* DCI(IDEM))+ LOCEL(IPROF))* 0.3048D0
                     ELSE
C                       Elevations in meters
                        ELV = (ELV* DCI(IDEM)) + LOCEL(IPROF)
                     END IF
                  END IF

C*                Write the elevations to a direct access file.
                  CALL WRITEZ (IDEM,JRECRD,ELV)

C              End Loop on Nodes
               END DO

            END IF

C*       End loop on profiles
         END DO

         IF (GOTDOMFLG) THEN
C ---       Write information to DOMDETAIL.OUT debug file
C           regarding direct access files
            IF (IDEM .EQ. 1) THEN
               WRITE(DOMK,50) NUMDEM
  50           FORMAT('From INITER_DEM:',
     &              //'Information on Direct Access Files Within ',
     &                                    'User-specified Domain:',
     &              //'No. of DEM Files = ',I6/)
            END IF
            WRITE(DOMK,60) IDEM, NUMPRF(IDEM)
  60        FORMAT('Direct Access File for DEM File No. ',I6,
     &             ' Contains ',I7,' Profiles.')
C ---       If direct access is not empty, NUMPRF(IDEM) > 0,
C           loop through profiles to print out first and last
            IF (NUMPRF(IDEM) .GT. 0) THEN
               L_FirstProf = .TRUE.
               DO K = 1, NPROF(IDEM)
                  IF (L_FirstProf .AND. NUMNOD(K) .GT. 0) THEN
C ---                This is the first non-empty profile,
C                    or the first profile within the direct access file
                     WRITE(DOMK,70) XBASE(K),YBASE(K),NUMNOD(K)
  70                 FORMAT(/' XBASE, YBASE and NODES for First',
     &                                        ' Profile: ',2F16.4,I7)
                     L_FirstProf = .FALSE.
                  ELSE IF ((.NOT.L_FirstProf .AND. NUMNOD(K).EQ.0)) THEN
C ---                The last non-empty profile has just been passed,
C                    print out info for previous profile
                     WRITE(DOMK,80) XBASE(K-1),YBASE(K-1),NUMNOD(K-1)
  80                 FORMAT(' XBASE, YBASE and NODES for Last ',
     &                                        ' Profile: ',2F16.4,I7/)
                     EXIT
                  ELSE IF (K .EQ. NPROF(IDEM)) THEN
C ---                This is the last profile in the DEM file, this
C                    must also be the last profile in the direct access file
                     WRITE(DOMK,80) XBASE(K),YBASE(K),NUMNOD(K)
                     EXIT
                  END IF
               END DO
            ELSE
               WRITE(DOMK,*)
            END IF
         END IF

         CLOSE (IDXUNT(IDEM))
         CLOSE (IDRUNT(IDEM))
         CLOSE (IDMUNT(IDEM))
         JRECRD = 0

         CYCLE DEMLOOP

 95      CONTINUE
C        Error opening a DEM file

         RUNERR = .TRUE.
         WRITE(DUMMY,'("DEM#",I4)') MIN(IDEM,9999)
         CALL ERRHDL(PATH,MODNAM,'E','500',DUMMY)

         CLOSE (IDXUNT(IDEM))
         CLOSE (IDRUNT(IDEM))
         CLOSE (IDMUNT(IDEM))
         JRECRD = 0

         CYCLE DEMLOOP

 97      CONTINUE
C        Error reading a DEM file

         RUNERR = .TRUE.
         WRITE(DUMMY,'("DEM#",I4)') MIN(IDEM,9999)
         CALL ERRHDL(PATH,MODNAM,'E','510',DUMMY)

         CLOSE (IDXUNT(IDEM))
         CLOSE (IDRUNT(IDEM))
         CLOSE (IDMUNT(IDEM))
         JRECRD = 0

         CYCLE DEMLOOP

C     End loop on dem files
      END DO DEMLOOP

C     Close DOMDETAIL.OUT debug file
      CLOSE(DOMK)

      WRITE(*,*) 'Exiting INITER_DEM'

999   RETURN
      end subroutine

      SUBROUTINE GETPRO (IDM,IPROF,IERR, RC)
C***********************************************************************
C*       PURPOSE:  THIS SUBROUTINE WILL READ X,Y NODE OF THE BASELINE AND
C*              THE Z VALUES FROM A DEM PROFILE
C*
C*       PROGRAMMER: Jayant Hardikar, Roger Brode
C*
C*       DATE:    September 29, 1995
C*
C*       MODIFIED: June 30, 2008
C*
C*                Added error checking for maximum number of nodes,
C*                and modified read format to accept up to 5,000 nodes.
C*                Roger W. Brode, U.S. EPA, OAQPS, AQMG
C*
C*       INPUTS:  Raw Terrain Data (DEM) Files
C*
C*       OUTPUTS: Direct Access Binary Terrain Files
C*
C*       CALLED FROM:   MAIN
C***********************************************************************

C*    Variable Declarations
      USE MAIN1

      IMPLICIT NONE

      SAVE

      CHARACTER*12 MODNAM

      INTEGER IERR, IDM, IPROF, ROWNUM, COLNUM, COLZ
      INTEGER L, J1, J2, KK, RR, RC

      MODNAM = 'GETPRO'
      IERR   = 0

      NODES(IPROF) = 0

      IF (FT(IDM) .NE. 1) THEN
         READ (IDMUNT(IDM), 208, ERR = 99, END = 99)
     &         ROWNUM, COLNUM, NODES(IPROF)
  208    FORMAT (3I6)

C*       Deallocate and reallocate ZDEM array for this profile
         IF (ALLOCATED(ZDEM)) DEALLOCATE(ZDEM)
         ALLOCATE(ZDEM(NODES(IPROF)))
         BACKSPACE (IDMUNT(IDM))

         READ (IDMUNT(IDM),209,ERR=99,END=99)
     &         ROWNUM, COLNUM,
     &         NODES(IPROF), COLZ, XBASE(IPROF), YBASE(IPROF),
     &         LOCEL(IPROF), MINEL(IPROF), MAXEL(IPROF),
     &         (ZDEM(L), L=1,NODES(IPROF))
C*        Read format supports up to 100,000 nodes per profile
  209     FORMAT (2I6,2I6,2D24.15,D24.15,2D24.15,
     &            146I6,587(:/170I6),:/64I6,:)

      ELSE

         RC = RC + 1
         READ (IDMUNT(IDM),FMT=209, REC=RC, ERR = 99)
     &         ROWNUM, COLNUM, NODES(IPROF)

C*       Deallocate and reallocate ZDEM array for this profile
         IF (ALLOCATED(ZDEM)) DEALLOCATE(ZDEM)
         ALLOCATE(ZDEM(NODES(IPROF)))

         J1 = 1
         RR = 0
         IF (NODES(IPROF) .GT. 146) THEN
            J2 = 146
            RR = INT((NODES(IPROF) - 146)/170 + 1)
            IF (MODULO((NODES(IPROF) - 146),170) .EQ. 0) RR = RR - 1
         ELSE
            J2 = NODES(IPROF)
         END IF

         READ (IDMUNT(IDM),FMT=209, REC=RC, ERR = 99)
     &         ROWNUM, COLNUM,
     &         NODES(IPROF), COLZ, XBASE(IPROF), YBASE(IPROF),
     &         LOCEL(IPROF), MINEL(IPROF), MAXEL(IPROF),
     &         (ZDEM(L), L=J1,J2)

         IF (RR .NE. 0) THEN
            DO KK = 1 , RR
              RC = RC + 1
              J1 = J2 + 1
              J2 = J1 + 170 - 1
              IF (J2 .GT. NODES(IPROF)) J2 = NODES(IPROF)
              READ (IDMUNT(IDM), FMT=211, REC=RC, ERR = 99)
     &             (ZDEM(L), L=J1,J2)
  211          FORMAT(170I6)
            END DO
         END IF
      END IF

      GO TO 999

99    RUNERR = .TRUE.
      IERR   = -1
      WRITE(DUMMY,'("DEM#",I4)') MIN(IDM,9999)
      CALL ERRHDL(PATH,MODNAM,'E','510',DUMMY)

999   RETURN

      end subroutine

      SUBROUTINE GETNOD(IPR,INO)
C***********************************************************************
C*               GETNOD Module of AERMAP Terrain Preprocessor
C*
C*       PURPOSE: Determine the Coordinates of a DEM Point (L/L)
C*
C*       PROGRAMMER: Jayant Hardikar, Roger Brode
C*
C*       DATE:    September 29, 1995
C*
C*       MODIFIED: June 30, 2008
C*
C*                Corrected to use DYM, node spacing in 'Y' direction,
C*                to assign YNODE values in profile.
C*                Roger W. Brode, U.S. EPA, OAQPS, AQMG
C*
C*       INPUTS:  Profile Number, Node Number, Coordinates of Baseline
C*
C*       OUTPUTS: Coordinates of a DEM Point
C*
C*       CALLED FROM:   INITER
C***********************************************************************

C*    Variable Declarations
      USE MAIN1

      IMPLICIT NONE

      CHARACTER*12 MODNAM

      INTEGER INO, IPR

      MODNAM = 'GETNOD'

C*    For the baseline in a profile, the coords of a node are the same
c*    as the coords of the baseline
      IF (INO .EQ. 1) THEN
         XNODE = XBASE(IPR)
         YNODE = YBASE(IPR)

C*    Otherwise, calculate the coords based on the profile and node number
      ELSE
         XNODE = XBASE(IPR)
         YNODE = YNODE + DYM(IDEM)
      END IF

      RETURN
      end subroutine


      SUBROUTINE PERMIT(PERIM,IGO)
*
*
*       Check on existing multiple regularization.
*       ------------------------------------------
*
      INCLUDE 'common6.h'
      PARAMETER  (NMX=10,NMX3=3*NMX,NMXm=NMX*(NMX-1)/2)
      REAL*8  M,MASS,MC,MIJ,MKK
      COMMON/CLUMP/   BODYS(NCMAX,5),T0S(5),TS(5),STEPS(5),RMAXS(5),
     &                NAMES(NCMAX,5),ISYS(5)
      COMMON/CHAIN1/  XCH(NMX3),VCH(NMX3),M(NMX),
     &                ZZ(NMX3),WC(NMX3),MC(NMX),
     &                XI(NMX3),PI(NMX3),MASS,RINV(NMXm),RSUM,MKK(NMX),
     &                MIJ(NMX,NMX),TKK(NMX),TK1(NMX),INAME(NMX),NN
*
*
*       Search any existing subsystem.
      ISUB = 0
      ICHSUB = 1
      DO 10 L = 1,NSUB
*       Identify chain pointer for possible reduction of STEPS.
          IF (ISYS(L).EQ.3) ICHSUB = ISYS(L)
*       Distinguish between triple & quad case (denoted ISUB = 1 or 2).
          IF (JCOMP.LE.N.AND.NAMES(4,L).EQ.0) THEN
              ISUB = 1
      ELSE IF (JCOMP.GT.N.AND.NAMES(4,L).GT.0) THEN
              ISUB = 2
          END IF
   10 CONTINUE
*
*       Do not allow a second regularization of the same type.
      IF (ISUB.GT.0) THEN
*       See whether the case ISUB = 1 or 2 is used already.
          DO 20 L = 1,NSUB
              IF (ISUB.EQ.ISYS(L)) IGO = 1
   20     CONTINUE
*       Enforce chain termination at next extension if new system < RSUM/2.
          IF (PERIM.LT.0.5*RSUM.AND.IGO.GT.0) THEN
              STEPS(ICHSUB) = 0.0
          END IF
      END IF
*
      RETURN
*
      END


      subroutine mgt_killop (jj, iplant)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine performs the kill operation

      use basin_module
      use organic_mineral_mass_module
      use hru_module, only : hru, ihru, ipl
      use soil_module
      use plant_module
      use constituent_mass_module

      implicit none

      integer :: j                     !none           |HRU number
      integer :: k                     !none           |counter
      integer, intent (in) :: jj       !none           |counter
      integer, intent (in) :: iplant   !               |plant number xwalked from hlt_db()%plant and plants.plt
      integer :: ly                    !none           |soil layer

      j = jj
      ipl = iplant

      !! update root fractions in each layer
      call pl_rootfr

      !! allocate dead roots, N, P to soil layers
	  do ly = 1, soil(j)%nly
	      soil1(j)%tot(ly) = soil(j)%ly(ly)%rtfr * pl_mass(j)%root_com + soil1(j)%tot(ly)
      end do

      !! add above ground mass to residue pool
      rsd1(j)%tot(1) = pl_mass(j)%ab_gr(ipl) + rsd1(j)%tot(1)

      !! zero all plant mass
      pl_mass(j)%tot(ipl) = plt_mass_z
      pl_mass(j)%ab_gr(ipl) = plt_mass_z
      pl_mass(j)%leaf(ipl) = plt_mass_z
      pl_mass(j)%stem(ipl) = plt_mass_z
      pl_mass(j)%seed(ipl) = plt_mass_z
      pl_mass(j)%root(ipl) = plt_mass_z

      do k = 1, cs_db%num_pests
        cs_soil(j)%ly(1)%pest(k) = cs_soil(j)%ly(1)%pest(k) !+ cs_pl(j)%pest(k)
        cs_pl(j)%pest(k) = 0.
      end do

	  !! reset plant variables
      pcom(j)%plg(ipl) = plgz
      pcom(j)%plm(ipl) = plmz
      pcom(j)%plstr(ipl) = plstrz
      !! can't reset entire plcur - harv_num can't be zero'd
      pcom(j)%plcur(ipl)%gro = "n"
      pcom(j)%plcur(ipl)%idorm = "n"
      pcom(j)%plcur(ipl)%phuacc = 0.
      pcom(j)%plcur(ipl)%curyr_mat = 1

      return
      end subroutine mgt_killop