program da_rad_diags
!
! Author: Hui-Chuan Lin
!
! program to read multiple-time of radiance innovation files and write out in
! netcdf format for ncl time-series plotting
!
! input files: (1)  namelist.da_rad_diags
!                   &record1
!                    nproc = 16   (the proc numbers used when inv files were written out)
!                    instid = 'dmsp-16-ssmis'   (inst names, can be more than one instid)
!                    file_prefix = "inv"
!                    start_date = '2005082000'
!                    end_date   = '2005083018'
!                    cycle_period  = 6
!                   /
!              (2) inv_* or oma_* from wrfvar

   implicit none

#include "netcdf.inc"
!
! namelist variables
!
   namelist /record1/ nproc, instid, file_prefix, start_date, end_date, cycle_period
           ! nproc: number of processsors used when writing out inv files
           ! instid, eg dmsp-16-ssmis
           ! file_prefix, inv or oma
           ! start_date, end_date, eg 2006100100, 2006102800
           ! cycle_period (hours) between dates, eg 6 or 12
   integer, parameter                     :: maxnum = 20, maxlvl = 100
   integer                                :: nml_unit = 87
   integer                                :: nproc, nlev, ilev, ich
   integer                                :: cycle_period, nlev_rtm, nlev_mdl
   character(len=20), dimension(maxnum)   :: instid
   character(len=6)                       :: file_prefix
   character(len=10)                      :: start_date, end_date
!
! netcdf variables
!
   character(len=200)                     :: ncname
   integer                                :: ncid, dimid, varid
   integer, dimension(3)                  :: ishape, istart, icount
!
   logical                                :: amsr2
   logical                                :: isfile, prf_found, jac_found
   integer, parameter                     :: datelen1 = 10
   integer, parameter                     :: datelen2 = 19
   real*4, parameter                      :: missing_r = -888888.00
   character(len=20)                      :: rtm_option    ! CRTM or RTTOV
   character(len=250)                     :: buf, inst
   character(len=7)                       :: numbuf
   character(len=datelen1)                :: valid_date
   integer                                :: ninst, iinst, iproc, ipixel, ifirst
   integer                                :: ios, i, n, ips, ipe, nerr, itime, itmp
   integer                                :: ntime, nchan, total_npixel
   integer, dimension(:), allocatable     :: ichan, npixel, iunit, scanpos, isflg
   integer, dimension(:), allocatable     :: landsea_mask, soiltyp, vegtyp
   real*4,  dimension(:), allocatable     :: lat, lon, elv, elev
   real*4,  dimension(:), allocatable     :: ret_clw
   real*4,  dimension(:), allocatable     :: satzen, satazi, t2m, mr2m, u10, v10, ps, ts
   real*4,  dimension(:), allocatable     :: smois, tslb, snowh, vegfra, clwp
   integer, dimension(:,:), allocatable   :: tb_qc
   real*4,  dimension(:,:), allocatable   :: tb_obs, tb_bak, tb_inv, tb_oma, tb_err, ems, ems_jac
   real*4,  dimension(:,:), allocatable   :: prf_pfull, prf_phalf, prf_t, prf_q, prf_water
   real*4,  dimension(:,:), allocatable   :: prf_ice, prf_rain, prf_snow, prf_grau, prf_hail
   real*4,  dimension(:,:), allocatable   :: prf_water_reff, prf_ice_reff, prf_rain_reff
   real*4,  dimension(:,:), allocatable   :: prf_snow_reff, prf_grau_reff, prf_hail_reff
   real*4,  dimension(:,:), allocatable   :: rtm_prf_p, rtm_prf_t, rtm_prf_q
   real*4,  dimension(:,:), allocatable   :: mdl_prf_p, mdl_prf_t, mdl_prf_q, mdl_prf_qcw, mdl_prf_qrn
   real*4,  dimension(:,:,:), allocatable :: prf_t_jac, prf_q_jac, prf_der_trans, prf_trans_jac, prf_trans, prf_lod_jac, prf_lod
   real*4,  dimension(:,:,:), allocatable :: prf_water_jac, prf_ice_jac, prf_rain_jac, prf_snow_jac, prf_grau_jac, prf_hail_jac
   real*4,  dimension(:,:,:), allocatable :: prf_water_reff_jac, prf_ice_reff_jac, prf_rain_reff_jac
   real*4,  dimension(:,:,:), allocatable :: prf_snow_reff_jac, prf_grau_reff_jac, prf_hail_reff_jac
   character(len=200), dimension(:), allocatable      :: inpname
   character(len=datelen1), dimension(:), allocatable :: datestr1          ! date string
   character(len=datelen2), dimension(:), allocatable :: datestr2          ! date string
!
! initialize some variables

   instid   = ''
   ninst    = 0
   file_prefix = 'inv'
   ilev = 0
   nlev = 0
   nlev_rtm = 0
   nlev_mdl = 0
   prf_found = .false.
   jac_found = .false.
   rtm_option = 'unknown'
!
! read namelist
!
   open(unit=nml_unit, file='namelist.da_rad_diags', status='old', form='formatted')
   read(unit=nml_unit, nml=record1, iostat=ios)
   write(0,nml=record1)
   if ( ios /= 0 ) then
      write(0,*) 'Error reading namelist record1'
      stop
   end if
!
! find out how many instruments to process
!
   do i = 1, maxnum
      if ( len_trim(instid(i)) /= 0 ) then
         ninst = ninst + 1
      end if
   end do
!
! find out how many dates to process
!
   ntime = 0
   valid_date = start_date
   do while ( valid_date <= end_date )
      ntime = ntime + 1
      call advance_cymdh(valid_date, cycle_period, valid_date)
   end do
   write(0,*) 'ntime = ', ntime

   allocate ( datestr1(ntime) )
   valid_date = start_date
   datestr1(1) = start_date
   do i = 2, ntime
      call advance_cymdh(datestr1(i-1), cycle_period, datestr1(i))
   end do

ntime_loop: do itime = 1, ntime

   write(0,*) '=================='
   write(0,*) trim(datestr1(itime))

   ninst_loop: do iinst = 1, ninst

      write(0,*) '------------------'
      write(0,*) trim(instid(iinst))

      amsr2 = index(instid(iinst),'amsr2') > 0

      nerr = 0
      total_npixel = 0
      ips = 0
      ipe = 0

      allocate ( npixel(0:nproc-1) )
      allocate ( iunit(0:nproc-1) )
      allocate ( inpname(0:nproc-1) )

      nproc_loop_1: do iproc = 0, nproc - 1   ! loop for first getting number of pixels from each proc

         write(unit=inpname(iproc), fmt='(a,i4.4)')  &
            trim(datestr1(itime))//'/'//trim(adjustl(file_prefix))//'_'//trim(instid(iinst))//'.', iproc
         iunit(iproc) = 101 + iproc
         inquire(file=trim(inpname(iproc)), exist=isfile)
         if ( .not. isfile ) Then
            write(0,*) 'Error opening innovation radiance file ', trim(inpname(iproc))
            nerr = nerr + 1
            if ( nerr == nproc ) then
               write(0,*) 'found no vaild files for ', trim(instid(iinst))
               deallocate ( npixel )
               deallocate ( iunit )
               deallocate ( inpname )
               cycle ninst_loop
            end if
            cycle nproc_loop_1
         end if

         open(unit=iunit(iproc),file=trim(inpname(iproc)),form='formatted',iostat=ios)
         read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf   ! first read in one line

         inst = buf(1:(index(buf,'number-of-pixels')-2))   ! retrieve inst name
         !
         ! retrieve number of pixels
         !
         numbuf = buf((index(buf,'channel-number')-8):(index(buf,'channel-number')-2))
         read(numbuf,'(i7)') npixel(iproc)

         total_npixel = total_npixel + npixel(iproc)

         itmp = 0
         do while ( ios == 0 .and. itmp < 2 )
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf
            if ( index(buf,'INFO :') > 0 ) then
               itmp = itmp + 1
            else
               if ( index(buf,'EMS_JACOBIAN') > 0 ) then
                  jac_found = .true.
               end if
               if ( index(buf,'level fullp(mb)') > 0 ) then
                  prf_found = .true.
                  rtm_option = 'CRTM'
               end if
               if ( index(buf,'RTM_level pres(mb)') > 0 ) then
                  prf_found = .true.
                  rtm_option = 'RTTOV'
               end if
            end if
            if ( rtm_option /= 'unknown' ) exit
         end do

      end do nproc_loop_1

      write(0,*) 'total_npixel = ', total_npixel

      ifirst = 1
      nproc_loop_2: do iproc = 0, nproc - 1

         inquire(file=trim(inpname(iproc)), exist=isfile)
         if ( .not. isfile ) cycle nproc_loop_2
         rewind(iunit(iproc))
         read(unit=iunit(iproc),fmt='(a)') buf
         !
         ! retrieve number of channels
         !
         numbuf = buf((index(buf,'index-of-channels')-6):(index(buf,'index-of-channels')-2))
         read(numbuf,'(i5)') nchan

         if ( .not. allocated(ichan) ) allocate (   ichan(1:nchan) )

         read(unit=iunit(iproc),fmt='(10i5)',iostat=ios) ichan
         read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf      ! pixel-info line
         read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf      ! xb-surf-info line

         if ( ifirst == 1 ) then

            allocate (     datestr2(1:total_npixel) )
            allocate (      scanpos(1:total_npixel) )
            allocate ( landsea_mask(1:total_npixel) )
            allocate (          elv(1:total_npixel) )
            allocate (          lat(1:total_npixel) )
            allocate (          lon(1:total_npixel) )
            allocate (       satzen(1:total_npixel) )
            allocate (       satazi(1:total_npixel) )
            allocate (      ret_clw(1:total_npixel) ) !obs retrieved clw
            allocate (          t2m(1:total_npixel) )
            allocate (         mr2m(1:total_npixel) )
            allocate (          u10(1:total_npixel) )
            allocate (          v10(1:total_npixel) )
            allocate (           ps(1:total_npixel) )
            allocate (           ts(1:total_npixel) )
            allocate (        smois(1:total_npixel) )
            allocate (         tslb(1:total_npixel) )
            allocate (        snowh(1:total_npixel) )
            allocate (        isflg(1:total_npixel) )
            allocate (      soiltyp(1:total_npixel) )
            allocate (       vegtyp(1:total_npixel) )
            allocate (       vegfra(1:total_npixel) )
            allocate (         elev(1:total_npixel) )
            allocate (         clwp(1:total_npixel) ) !model/guess clwp
            allocate ( tb_obs(1:nchan,1:total_npixel) )
            allocate ( tb_bak(1:nchan,1:total_npixel) )
            allocate ( tb_inv(1:nchan,1:total_npixel) )
            allocate ( tb_oma(1:nchan,1:total_npixel) )
            allocate ( tb_err(1:nchan,1:total_npixel) )
            allocate (  tb_qc(1:nchan,1:total_npixel) )
            allocate (    ems(1:nchan,1:total_npixel) )
            if ( jac_found ) then
               allocate ( ems_jac(1:nchan,1:total_npixel) )
            end if
            if ( prf_found .and. (rtm_option == 'CRTM') ) then
               allocate ( prf_pfull(1:maxlvl,1:total_npixel) )
               allocate ( prf_phalf(1:maxlvl,1:total_npixel) )
               allocate ( prf_t(1:maxlvl,1:total_npixel) )
               allocate ( prf_q(1:maxlvl,1:total_npixel) )
               allocate ( prf_water(1:maxlvl,1:total_npixel) )
               allocate ( prf_ice(1:maxlvl,1:total_npixel) )
               allocate ( prf_rain(1:maxlvl,1:total_npixel) )
               allocate ( prf_snow(1:maxlvl,1:total_npixel) )
               allocate ( prf_grau(1:maxlvl,1:total_npixel) )
               allocate ( prf_hail(1:maxlvl,1:total_npixel) )
               allocate ( prf_water_reff(1:maxlvl,1:total_npixel) )
               allocate ( prf_ice_reff(1:maxlvl,1:total_npixel) )
               allocate ( prf_rain_reff(1:maxlvl,1:total_npixel) )
               allocate ( prf_snow_reff(1:maxlvl,1:total_npixel) )
               allocate ( prf_grau_reff(1:maxlvl,1:total_npixel) )
               allocate ( prf_hail_reff(1:maxlvl,1:total_npixel) )
               if ( jac_found ) then
                  allocate ( prf_t_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_q_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_der_trans(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_trans_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_trans(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_lod_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_lod(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_water_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_ice_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_rain_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_snow_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_grau_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_hail_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_water_reff_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_ice_reff_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_rain_reff_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_snow_reff_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_grau_reff_jac(1:maxlvl,1:nchan,1:total_npixel) )
                  allocate ( prf_hail_reff_jac(1:maxlvl,1:nchan,1:total_npixel) )
               end if
            end if
            if ( prf_found .and. (rtm_option == 'RTTOV') ) then
               allocate ( rtm_prf_p(1:maxlvl,1:total_npixel) )
               allocate ( rtm_prf_t(1:maxlvl,1:total_npixel) )
               allocate ( rtm_prf_q(1:maxlvl,1:total_npixel) )  ! in ppmv
               allocate ( mdl_prf_p(1:maxlvl,1:total_npixel) )
               allocate ( mdl_prf_t(1:maxlvl,1:total_npixel) )
               allocate ( mdl_prf_q(1:maxlvl,1:total_npixel) )  ! in g/kg
               allocate ( mdl_prf_qcw(1:maxlvl,1:total_npixel) )
               allocate ( mdl_prf_qrn(1:maxlvl,1:total_npixel) )
               ! initialize
               rtm_prf_p = missing_r
               rtm_prf_t = missing_r
               rtm_prf_q = missing_r
               mdl_prf_p = missing_r
               mdl_prf_t = missing_r
               mdl_prf_q = missing_r
               mdl_prf_qcw = missing_r
               mdl_prf_qrn = missing_r
            end if
            ! initialize
            tb_obs = missing_r
            tb_bak = missing_r
            tb_inv = missing_r
            tb_oma = missing_r
            tb_err = missing_r
            ncname = 'diags_'//trim(instid(iinst))//"_"//datestr1(itime)//'.nc'
            ios = NF_CREATE(trim(ncname), NF_CLOBBER, ncid)  ! NF_CLOBBER specifies the default behavior of
                                                             ! overwritting any existing dataset with the
                                                             ! same file name
            if ( ios /= 0 ) then
               write(0,*) 'Error creating netcdf file: ', ncname
               stop
            end if

            ifirst = 0

         end if   ! end of ifirst if
!
!        decide the index of pixels to store data in
!
         ips = ipe + 1
         ipe = ipe + npixel(iproc)
         write(0,*) 'Processing pixels ', ips, ' to ', ipe

         npixel_loop: do ipixel = ips, ipe

            read(unit=iunit(iproc),fmt='(7x,i7,2x,a19,i6,i3,f6.0,4f8.2,f8.3)',iostat=ios)  &
               n, datestr2(ipixel), scanpos(ipixel), landsea_mask(ipixel), elv(ipixel), &
               lat(ipixel), lon(ipixel), satzen(ipixel), satazi(ipixel), ret_clw(ipixel)

            read(unit=iunit(iproc),fmt='(14x,9f10.2,3i3,3f10.2)',iostat=ios)  &
               t2m(ipixel), mr2m(ipixel), u10(ipixel), v10(ipixel), ps(ipixel), ts(ipixel), &
               smois(ipixel), tslb(ipixel), snowh(ipixel), isflg(ipixel), soiltyp(ipixel),  &
               vegtyp(ipixel), vegfra(ipixel), elev(ipixel), clwp(ipixel)
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf           ! OBS
            read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_obs(:,ipixel)
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf           ! BAK
            read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_bak(:,ipixel)
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf           ! IVBC
            read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_inv(:,ipixel)
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf           ! OMA or EMS
            if ( buf(1:3) == "OMA" ) then
               read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_oma(:,ipixel)
               read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf        ! OMA or EMS
            end if
            read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) ems(:,ipixel)
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf           ! EMS_JACOBIAN or ERR
            if ( buf(1:12) == "EMS_JACOBIAN" ) then
               read(unit=iunit(iproc),fmt='(10f10.3)',iostat=ios) ems_jac(:,ipixel)
               read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf        ! OMA or EMS
            end if
            read(unit=iunit(iproc),fmt='(10f11.2)',iostat=ios) tb_err(:,ipixel)
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf           ! QC
            read(unit=iunit(iproc),fmt='(10i11)',iostat=ios  ) tb_qc(:,ipixel)
            read(unit=iunit(iproc),fmt='(a)',iostat=ios) buf
            if ( buf(1:4) == "INFO" ) then
               backspace(iunit(iproc))
               cycle npixel_loop
            else
               if ( index(buf(1:6),'level') > 0 ) then    ! CRTM profiles are available
                  ilev = 0
                  do while ( ios == 0 )
                     ilev = ilev + 1
                     read(unit=iunit(iproc),fmt='(3x,2f10.2,f8.2,13f8.3)',iostat=ios)        &
                        prf_pfull(ilev,ipixel), prf_phalf(ilev,ipixel), prf_t(ilev,ipixel),  &
                        prf_q(ilev,ipixel), prf_water(ilev,ipixel), prf_ice(ilev,ipixel),    &
                        prf_rain(ilev,ipixel), prf_snow(ilev,ipixel), prf_grau(ilev,ipixel), &
                        prf_hail(ilev,ipixel),prf_water_reff(ilev,ipixel),                   &
                        prf_ice_reff(ilev,ipixel), prf_rain_reff(ilev,ipixel),               &
                        prf_snow_reff(ilev,ipixel), prf_grau_reff(ilev,ipixel),              &
                        prf_hail_reff(ilev,ipixel)
                  end do
                  nlev = ilev - 1
                  ! backspace(iunit(iproc))
               else if ( index(buf, 'RTM_level') > 0 ) then  ! RTTOV profiles are available
                  ! first, RTTOV levels
                  ilev = 0
                  do while ( ios == 0 )
                     ilev = ilev + 1
                     read(unit=iunit(iproc),fmt='(3x,f10.2,f8.2,e11.4)',iostat=ios)        &
                        rtm_prf_p(ilev,ipixel), rtm_prf_t(ilev,ipixel),                    &
                        rtm_prf_q(ilev,ipixel)  ! q in ppmv
                  end do
                  nlev_rtm = ilev - 1
                  ! second, Model levels
                  ios  = 0
                  ilev = 0
                  do while ( ios == 0 )
                     ilev = ilev + 1
                     read(unit=iunit(iproc),fmt='(3x,f10.2,f8.2,3e11.4)',iostat=ios)        &
                        mdl_prf_p(ilev,ipixel), mdl_prf_t(ilev,ipixel),                     &
                        mdl_prf_q(ilev,ipixel), mdl_prf_qcw(ilev,ipixel),                   &
                        mdl_prf_qrn(ilev,ipixel)
                  end do
                  nlev_mdl = ilev - 1
               end if

               if ( jac_found ) then
                  ios = 0
                  do while ( ios == 0 )
                     ! ilev = ilev + 1
                     read(unit=iunit(iproc),fmt='(i5,i3,10x,19f14.7)',iostat=ios)               &
                        ich, ilev, prf_t_jac(ilev,ich,ipixel), prf_q_jac(ilev,ich,ipixel),     &
                        prf_der_trans(ilev,ich,ipixel),                                        &
                        prf_trans_jac(ilev,ich,ipixel), prf_trans(ilev,ich,ipixel),       &
                        prf_lod_jac(ilev,ich,ipixel), prf_lod(ilev,ich,ipixel),           &
                        prf_water_jac(ilev,ich,ipixel), prf_ice_jac(ilev,ich,ipixel),          &
                        prf_rain_jac(ilev,ich,ipixel), prf_snow_jac(ilev,ich,ipixel),          &
                        prf_grau_jac(ilev,ich,ipixel), prf_hail_jac(ilev,ich,ipixel),          &
                        prf_water_reff_jac(ilev,ich,ipixel), prf_ice_reff_jac(ilev,ich,ipixel), &
                        prf_rain_reff_jac(ilev,ich,ipixel), prf_snow_reff_jac(ilev,ich,ipixel), &
                        prf_grau_reff_jac(ilev,ich,ipixel), prf_hail_reff_jac(ilev,ich,ipixel)
                     nlev = max(nlev,ilev)
                  end do
                  backspace(iunit(iproc))
               else
                  backspace(iunit(iproc))
               end if
            end if

         end do npixel_loop

         close(iunit(iproc))

      end do nproc_loop_2

      write(0,*) 'Writing out data in netCDF format...'
      !
      ! define dimensions
      !
      ios = NF_DEF_DIM(ncid, 'nchan', nchan, dimid)
      ios = NF_DEF_DIM(ncid, 'npixel', total_npixel, dimid)
      ios = NF_DEF_DIM(ncid, 'DateStrLen', datelen2, dimid)
      if ( prf_found .or. jac_found ) then
         if ( rtm_option == 'RTTOV' ) then
            nlev = max(nlev_rtm,nlev_mdl)
         end if
         ios = NF_DEF_DIM(ncid, 'nlev', nlev, dimid)
      end if
      !
      ! output global attributes
      !
      if ( trim(rtm_option) == 'unknown' ) then
         if ( maxval(mr2m) < -8000.0 ) then
            rtm_option = 'CRTM'
         else
            rtm_option = 'RTTOV'
         end if
      end if
      ios = NF_PUT_ATT_TEXT (ncid, NF_GLOBAL, 'rtm_option', 20, rtm_option)
      !
      ! define variables
      !
      ! define 2-D array for date string
      !
      ios = NF_INQ_DIMID(ncid, 'DateStrLen', dimid)
      ishape(1) = dimid
      ios = NF_INQ_DIMID(ncid, 'npixel', dimid)
      ishape(2) = dimid
      ios = NF_DEF_VAR(ncid, 'date',   NF_CHAR,  2, ishape(1:2), varid)
      !
      ! define 2-D array with dimensions nchan * total_npixel
      !
      ios = NF_INQ_DIMID(ncid, 'nchan', dimid)
      ishape(1) = dimid
      ios = NF_INQ_DIMID(ncid, 'npixel', dimid)
      ishape(2) = dimid
      ios = NF_DEF_VAR(ncid, 'tb_obs', NF_FLOAT, 2, ishape(1:2), varid)
      ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r)
      ios = NF_DEF_VAR(ncid, 'tb_bak', NF_FLOAT, 2, ishape(1:2), varid)
      ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r)
      ios = NF_DEF_VAR(ncid, 'tb_inv', NF_FLOAT, 2, ishape(1:2), varid)
      ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r)
      ios = NF_DEF_VAR(ncid, 'tb_oma', NF_FLOAT, 2, ishape(1:2), varid)
      ios = NF_PUT_ATT_REAL(ncid, varid, 'missing_value', NF_FLOAT, 1, missing_r)
      ios = NF_DEF_VAR(ncid, 'ems',    NF_FLOAT, 2, ishape(1:2), varid)
      if ( jac_found ) then
         ios = NF_DEF_VAR(ncid, 'ems_jac',NF_FLOAT, 2, ishape(1:2), varid)
      end if
      ios = NF_DEF_VAR(ncid, 'tb_err', NF_FLOAT, 2, ishape(1:2), varid)
      ios = NF_DEF_VAR(ncid, 'tb_qc',  NF_INT,   2, ishape(1:2), varid)
      !
      ! define 2-D array with dimensions nlev * total_npixel
      !
      if ( prf_found ) then
         ios = NF_INQ_DIMID(ncid, 'nlev', dimid)
         ishape(1) = dimid
         ios = NF_INQ_DIMID(ncid, 'npixel', dimid)
         ishape(2) = dimid
         if ( rtm_option == 'CRTM' ) then
            ios = NF_DEF_VAR(ncid, 'prf_pfull', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_phalf', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_t',     NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_q',     NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_water', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_ice',   NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_rain',  NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_snow',  NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_grau',  NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_hail',  NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_water_reff', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_ice_reff',   NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_rain_reff',  NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_snow_reff',  NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_grau_reff',  NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'prf_hail_reff',  NF_FLOAT, 2, ishape(1:2), varid)
         else if ( rtm_option == 'RTTOV' ) then
            ios = NF_DEF_VAR(ncid, 'rtm_prf_p', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'rtm_prf_t', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'rtm_prf_q', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'mdl_prf_p', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'mdl_prf_t', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'mdl_prf_q', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'mdl_prf_qcw', NF_FLOAT, 2, ishape(1:2), varid)
            ios = NF_DEF_VAR(ncid, 'mdl_prf_qrn', NF_FLOAT, 2, ishape(1:2), varid)
         end if
      end if
      !
      ! define 3-D array with dimensions nlev * nchan * total_npixel
      !
      if ( jac_found ) then
         ios = NF_INQ_DIMID(ncid, 'nlev', dimid)
         ishape(1) = dimid
         ios = NF_INQ_DIMID(ncid, 'nchan', dimid)
         ishape(2) = dimid
         ios = NF_INQ_DIMID(ncid, 'npixel', dimid)
         ishape(3) = dimid
         ios = NF_DEF_VAR(ncid, 'prf_t_jac',     NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_q_jac',     NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_der_trans',     NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_trans_jac', NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_trans', NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_lod_jac', NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_lod', NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_water_jac', NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_ice_jac',   NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_rain_jac',  NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_snow_jac',  NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_grau_jac',  NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_hail_jac',  NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_water_reff_jac', NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_ice_reff_jac',   NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_rain_reff_jac',  NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_snow_reff_jac',  NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_grau_reff_jac',  NF_FLOAT, 3, ishape, varid)
         ios = NF_DEF_VAR(ncid, 'prf_hail_reff_jac',  NF_FLOAT, 3, ishape, varid)
      end if
      !
      ! define 1-D array with dimension nchan
      !
      ios = NF_INQ_DIMID(ncid, 'nchan', dimid)
      ishape(1) = dimid
      ios = NF_DEF_VAR(ncid, 'ichan',  NF_INT,   1, ishape(1), varid)   ! channel index
      !
      ! define 1-D array with dimension total_npixel
      !
      ios = NF_INQ_DIMID(ncid, 'npixel', dimid)
      ishape(1) = dimid
      ios = NF_DEF_VAR(ncid, 'scanpos',      NF_INT,   1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'landsea_mask', NF_INT,   1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'elv',          NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'lat',          NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'lon',          NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'satzen',       NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'satazi',       NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 't2m',          NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'mr2m',         NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'u10',          NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'v10',          NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'ps',           NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'ts',           NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'tslb',         NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'smois',        NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'snowh',        NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'isflg',        NF_INT,   1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'soiltyp',      NF_INT,   1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'vegtyp',       NF_INT,   1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'vegfra',       NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'elev',         NF_FLOAT, 1, ishape(1), varid)
      ios = NF_DEF_VAR(ncid, 'clwp',         NF_FLOAT, 1, ishape(1), varid)
      if ( amsr2 ) then
         ios = NF_DEF_VAR(ncid, 'ret_clw',   NF_FLOAT, 1, ishape(1), varid)
      end if

      ios = NF_ENDDEF(ncid)
      !
      ! output date string
      istart(1) = 1
      istart(2) = 1
      icount(1) = datelen2
      icount(2) = total_npixel
      ios = NF_INQ_VARID (ncid, 'date', varid)
      ios = NF_PUT_VARA_TEXT(ncid, varid, istart, icount, datestr2)
      !
      ! output 2-D array with dimensions nchan * total_npixel
      !
      istart(1) = 1
      istart(2) = 1
      icount(1) = nchan
      icount(2) = total_npixel
      ios = NF_INQ_VARID (ncid, 'tb_obs', varid)
      ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_obs)
      ios = NF_INQ_VARID (ncid, 'tb_bak', varid)
      ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_bak)
      ios = NF_INQ_VARID (ncid, 'tb_inv', varid)
      ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_inv)
      ios = NF_INQ_VARID (ncid, 'tb_oma', varid)
      ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_oma)
      ios = NF_INQ_VARID (ncid, 'ems', varid)
      ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), ems)
      if ( jac_found ) then
         ios = NF_INQ_VARID (ncid, 'ems_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), ems_jac)
      end if
      ios = NF_INQ_VARID (ncid, 'tb_err', varid)
      ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), tb_err)
      ios = NF_INQ_VARID (ncid, 'tb_qc', varid)
      ios = NF_PUT_VARA_INT(ncid,  varid, istart(1:2), icount(1:2), tb_qc)
      !
      ! output 2-D array with dimensions nlev * total_npixel
      !
      if ( prf_found ) then
         istart(1) = 1
         istart(2) = 1
         icount(1) = nlev
         icount(2) = total_npixel
         if ( rtm_option == 'CRTM' ) then
            ios = NF_INQ_VARID (ncid, 'prf_pfull', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_pfull(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_phalf', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_phalf(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_t', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_t(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_q', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_q(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_water', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_water(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_ice', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_ice(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_rain', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_rain(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_snow', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_snow(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_grau', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_grau(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_hail', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_hail(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_water_reff', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_water_reff(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_ice_reff', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_ice_reff(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_rain_reff', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_rain_reff(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_snow_reff', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_snow_reff(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_grau_reff', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_grau_reff(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'prf_hail_reff', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), prf_hail_reff(1:nlev,:))
         else if ( rtm_option == 'RTTOV' ) then
            ios = NF_INQ_VARID (ncid, 'rtm_prf_p', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), rtm_prf_p(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'rtm_prf_t', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), rtm_prf_t(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'rtm_prf_q', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), rtm_prf_q(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'mdl_prf_p', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), mdl_prf_p(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'mdl_prf_t', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), mdl_prf_t(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'mdl_prf_q', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), mdl_prf_q(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'mdl_prf_qcw', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), mdl_prf_qcw(1:nlev,:))
            ios = NF_INQ_VARID (ncid, 'mdl_prf_qrn', varid)
            ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:2), icount(1:2), mdl_prf_qrn(1:nlev,:))
         end if
      end if
      !
      ! output 3-D array with dimensions nlev * nchan * total_npixel
      !
      if ( jac_found ) then
         istart(1) = 1
         istart(2) = 1
         istart(3) = 1
         icount(1) = nlev
         icount(2) = nchan
         icount(3) = total_npixel
         ios = NF_INQ_VARID (ncid, 'prf_t_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_t_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_q_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_q_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_der_trans', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_der_trans(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_trans_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_trans_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_trans', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_trans(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_lod_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_lod_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_lod', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_lod(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_water_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_water_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_ice_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_ice_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_rain_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_rain_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_snow_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_snow_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_grau_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_grau_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_hail_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_hail_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_water_reff_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_water_reff_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_ice_reff_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_ice_reff_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_rain_reff_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_rain_reff_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_snow_reff_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_snow_reff_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_grau_reff_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_grau_reff_jac(1:nlev,:,:))
         ios = NF_INQ_VARID (ncid, 'prf_hail_reff_jac', varid)
         ios = NF_PUT_VARA_REAL(ncid, varid, istart(1:3), icount(1:3), prf_hail_reff_jac(1:nlev,:,:))
      end if
      !
      ! output 1-D array with dimension nchan
      !
      istart(1) = 1
      icount(1) = nchan
      ios = NF_INQ_VARID (ncid, 'ichan', varid)
      ios = NF_PUT_VARA_INT(ncid,  varid, istart(1), icount(1), ichan)
      !
      ! output 1-D array with dimension total_npixel
      !
      istart(2) = 1
      icount(2) = total_npixel
      ios = NF_INQ_VARID (ncid, 'scanpos', varid)
      ios = NF_PUT_VARA_INT(ncid,  varid, istart(2), icount(2), scanpos)
      ios = NF_INQ_VARID (ncid, 'landsea_mask', varid)
      ios = NF_PUT_VARA_INT(ncid,  varid, istart(2), icount(2), landsea_mask)
      ios = NF_INQ_VARID (ncid, 'elv', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), elv)
      ios = NF_INQ_VARID (ncid, 'lat', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), lat)
      ios = NF_INQ_VARID (ncid, 'lon', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), lon)
      ios = NF_INQ_VARID (ncid, 'satzen', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), satzen)
      ios = NF_INQ_VARID (ncid, 'satazi', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), satazi)
      ios = NF_INQ_VARID (ncid, 't2m', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), t2m)
      ios = NF_INQ_VARID (ncid, 'mr2m', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), mr2m)
      ios = NF_INQ_VARID (ncid, 'u10', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), u10)
      ios = NF_INQ_VARID (ncid, 'v10', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), v10)
      ios = NF_INQ_VARID (ncid, 'ps', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), ps)
      ios = NF_INQ_VARID (ncid, 'ts', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), ts)
      ios = NF_INQ_VARID (ncid, 'smois', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), smois)
      ios = NF_INQ_VARID (ncid, 'tslb', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), tslb)
      ios = NF_INQ_VARID (ncid, 'snowh', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), snowh)
      ios = NF_INQ_VARID (ncid, 'isflg', varid)
      ios = NF_PUT_VARA_INT(ncid,  varid, istart(2), icount(2), isflg)
      ios = NF_INQ_VARID (ncid, 'soiltyp', varid)
      ios = NF_PUT_VARA_INT(ncid,  varid, istart(2), icount(2), soiltyp)
      ios = NF_INQ_VARID (ncid, 'vegtyp', varid)
      ios = NF_PUT_VARA_INT(ncid,  varid, istart(2), icount(2), vegtyp)
      ios = NF_INQ_VARID (ncid, 'vegfra', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), vegfra)
      ios = NF_INQ_VARID (ncid, 'elev', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), elev)
      ios = NF_INQ_VARID (ncid, 'clwp', varid)
      ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), clwp)
      if ( amsr2 ) then
         ios = NF_INQ_VARID (ncid, 'ret_clw', varid)
         ios = NF_PUT_VARA_REAL(ncid,  varid, istart(2), icount(2), ret_clw)
      end if
      !
      ios = NF_CLOSE(ncid)

      deallocate ( npixel )
      deallocate ( iunit )
      deallocate ( inpname )

      deallocate ( ichan )
      deallocate ( datestr2 )
      deallocate ( scanpos )
      deallocate ( landsea_mask )
      deallocate ( elv )
      deallocate ( lat )
      deallocate ( lon )
      deallocate ( satzen )
      deallocate ( satazi )
      deallocate ( t2m )
      deallocate ( mr2m )
      deallocate ( u10 )
      deallocate ( v10 )
      deallocate ( ps )
      deallocate ( ts )
      deallocate ( smois )
      deallocate ( tslb )
      deallocate ( snowh )
      deallocate ( isflg )
      deallocate ( soiltyp )
      deallocate ( vegtyp )
      deallocate ( vegfra )
      deallocate ( elev )
      deallocate ( clwp )
      deallocate ( ret_clw )
      deallocate ( tb_obs )
      deallocate ( tb_bak )
      deallocate ( tb_inv )
      deallocate ( tb_oma )
      deallocate ( ems )
      if ( jac_found ) deallocate ( ems_jac )
      deallocate ( tb_err )
      deallocate ( tb_qc )
      if ( prf_found .and. (rtm_option == 'CRTM') ) then
         deallocate ( prf_pfull )
         deallocate ( prf_phalf )
         deallocate ( prf_t )
         deallocate ( prf_q )
         deallocate ( prf_water )
         deallocate ( prf_ice )
         deallocate ( prf_rain )
         deallocate ( prf_snow )
         deallocate ( prf_grau )
         deallocate ( prf_hail )
         deallocate ( prf_water_reff )
         deallocate ( prf_ice_reff )
         deallocate ( prf_rain_reff )
         deallocate ( prf_snow_reff )
         deallocate ( prf_grau_reff )
         deallocate ( prf_hail_reff )
         if ( jac_found ) then
            deallocate ( prf_t_jac )
            deallocate ( prf_q_jac )
            deallocate ( prf_der_trans )
            deallocate ( prf_trans_jac )
            deallocate ( prf_trans )
            deallocate ( prf_lod_jac )
            deallocate ( prf_lod )
            deallocate ( prf_water_jac )
            deallocate ( prf_ice_jac )
            deallocate ( prf_rain_jac )
            deallocate ( prf_snow_jac )
            deallocate ( prf_grau_jac )
            deallocate ( prf_hail_jac )
            deallocate ( prf_water_reff_jac )
            deallocate ( prf_ice_reff_jac )
            deallocate ( prf_rain_reff_jac )
            deallocate ( prf_snow_reff_jac )
            deallocate ( prf_grau_reff_jac )
            deallocate ( prf_hail_reff_jac )
         end if
      end if
      if ( prf_found .and. (rtm_option == 'RTTOV') ) then
         deallocate ( rtm_prf_p )
         deallocate ( rtm_prf_t )
         deallocate ( rtm_prf_q )
         deallocate ( mdl_prf_p )
         deallocate ( mdl_prf_t )
         deallocate ( mdl_prf_q )
         deallocate ( mdl_prf_qcw )
         deallocate ( mdl_prf_qrn )
      end if

   end do ninst_loop

end do ntime_loop

deallocate ( datestr1 )

end program da_rad_diags

subroutine advance_cymdh(currentdate,dh,newdate)

   implicit none

   character(len=10), intent(in)  :: currentdate
   integer,           intent(in)  :: dh
   character(len=10), intent(out) :: newdate

   integer :: ccyy, mm, dd, hh

   read(currentdate(1:10), fmt='(i4, 3i2)')  ccyy, mm, dd, hh
   hh = hh + dh
   do while (hh < 0)
      hh = hh + 24
      call change_date ( ccyy, mm, dd, -1 )
   end do
   do while (hh > 23)
      hh = hh - 24
      call change_date ( ccyy, mm, dd, 1 )
   end do
   write(newdate,'(i4.4,3(i2.2))') ccyy, mm, dd, hh

end subroutine advance_cymdh

subroutine change_date( ccyy, mm, dd, delta )

      implicit none

      integer, intent(inout) :: ccyy, mm, dd
      integer, intent(in)    :: delta
      integer, dimension(12) :: mmday

      mmday = (/31,28,31,30,31,30,31,31,30,31,30,31/)
      mmday(2) = 28
      if (mod(ccyy,4) == 0) then
         mmday(2) = 29
         if ( mod(ccyy,100) == 0) then
            mmday(2) = 28
         endif
         if(mod(ccyy,400) == 0) then
            mmday(2) = 29
         end if
      endif
      dd = dd + delta
      if(dd == 0) then
         mm = mm - 1
         if(mm == 0) then
            mm = 12
            ccyy = ccyy - 1
         endif
         dd = mmday(mm)
      elseif ( dd .gt. mmday(mm) ) then
         dd = 1
         mm = mm + 1
         if(mm > 12 ) then
            mm = 1
            ccyy = ccyy + 1
         end if
      end if

end subroutine change_date


c# decred.f
      SUBROUTINE DECRED
C---------------------------------
C
C     THIS ROUTINE CALLS FUNCTION MONITR TO READ THE CONTROL CARDS.
C     THE CARD IMAGES ARE THEN DECODED , PROCESSED AND THE DATA STORED
C
      use voacapl_defs
      use crun_directory
      character cirafz*30,zones(100)*4
      common /cCIRAF_TP/ nTP,idx_TP(911)
c jw      common /crun_directory/ run_directory
c jw         character run_directory*50
      common /ccoeff/ coeff
      character coeff*4
      common /cdaily/ idaily(12)       !  day of the month modification
      common /carea/ iarea
      common /c_S_to_I/ i_S_to_I    !  = 1 = S/I calculation
      common /cmodel/ model
      character model*8
      common /cantenna/ numants,iats(20),anttype(20),antname(20),
     +                  xfqs(20),xfqe(20),designfreq(20),antfile(20),
     +                  beammain(20),offazim(20),cond(20),diel(20),
     +                  array(30,91,20),aeff(30,20)
      character anttype*10,antname*70,antfile*24,gainfile*10
      dimension array91(91)
      common /pantenna/ pwrkw(20),pwrdba(20)    !  antenna powers
      common /chours/ nhours,ihours(24)       !  which hours are active
      COMMON /RGRID/ IPROJ,PLAT,PLON,XMIN,XMAX,YYMIN,YMAX,NX,NY
      COMMON / ALPHA / IMON(12), ITRAN(2), IRCVR(2), LBMAP(2), MODE(13),
     A MODER(13), ITLAT, ITLONG, IRLAT, IRLONG, IRLATU, IRLONGU, NYEAR
      CHARACTER IMON*3, NYEAR*5, ITRAN*10, IRCVR*10, LBMAP*10, ITLAT*1,
     A ITLONG*1, IRLAT*1, IRLONG*1, IRLATU*1, IRLONGU*1, MODE*2, MODER*2
      COMMON /CON/ D2R, DCL, GAMA, PI, PI2, PIO2, R2D, RZ, VOFL
      COMMON / CONTRL / IELECT(3), KTOUT(12), MONTHS(12), SUNSP(12),
     A IANTOU, ICARD, INTEG, IRED, ISOUT, ISPROC, ISSN, ITYPE, JDASH,
     B JFREQ, JLONG, KCARD, KRUN, MAPIN, MAXNAM, MONOLD, MOREM, MORES,
     C NUMNAM, NUPROC, MAXMET, MSPEC, M100
      COMMON /DON /ALATD, AMIN, AMIND, BTR, BTRD, DLONG, DMP, ERTR, GCD,
     1 GCDKM, PMP, PWR, TLAT, TLATD, TLONG, TLONGD, RSN, SIGTR, RLAT,
     2 RLATD,RLONG,RLONGD,BRTD,FLUX,ULAT,ULATD,ULONG,ULONGD,SSN,D90R,
     3 D50R,D10R,D90S,D50S,D10S
      COMMON /ES /FS (3, 5), HS (5)
      COMMON/FRQ/FREA(13),FREL(29),FREQ,JMODE,ITXRCP(2)
      COMMON /GEOG /GYZ (5), RAT (5), GMDIP (5), CLCK (5), ABIY (5), ART
     1IC (5), SIGPAT (5), EPSPAT (5)
      COMMON / ION / IHRE, IHRO, IHRS, LUFP, METHOD, NOISE, NPSL
      COMMON/LPATH/ GCDLNG,TXRGML(45,2),DELOPT,GMIN,YMIN,LTXRGM(2)
      COMMON / METSET / ITRUN, ITOUT, JTRUN(40), JTOUT(40)
      COMMON / MFAC / F2M3(5),HPF2(5),ZENANG(5),ZENMAX(5),IEDP,FSECV(3)
      COMMON / MODES / GHOP, DELMOD(6,3), HPMOD(6,3), HTMOD(6,3),
     1 FVMOD(6,3), ITMOD(6,3), AFMOD(6,3)
      COMMON / NAMEX / NAMES(100), INPUT
      CHARACTER INPUT*85
      COMMON / OUTLAB / LABEL(11), LAYTYP(5), IEAST, INORTH, ISOUTH,
     A IWEST, LABLI, LABLJ, LABLK
      COMMON / OUTPRT / LINBOT(26), LINBD(14), LINTOP(15), LINTP(14),
     A GRPTYP, JOUT, LINBYP, LINES, LINMAX, LINTYP, LPAGES, NLINE
      COMMON / RAYS / ANG(40), IFOB(40,30,5), NANG
      COMMON/REFLX/DELFX(45,3),HPFLX(45,3),HTFLX(45,3),GDFLX(45,3),FVFLX
     A (45,3),DSKPKM(3),DELSKP(3),HPSKP(3),HTSKP(3),DMAXKM(3),FVSKP(3)
     B ,ISKP(3),IMODE(45,3),AFFLX(45,3),DELPEN(3,5),GML(45,3),FHP(45,3)
      COMMON /RON /CLAT(5), CLONG(5), GLAT(5), RD(5), FI(3,5), YI(3,5),
     1HI(3,5), HPRIM(30,5), HTRUE(30,5), FVERT(30,5),KM,KFX, AFAC(30,5),
     2HTR(50,3), FNSQ(50,3)
      COMMON /SSP /SUN (2, 12), MONTH
      COMMON / TIME / IT, GMT, UTIME(24), GMTR, XLMT(24), ITIM, JTX
      COMMON /TON /ADJ, ADS, GNOS, GOT, REL, SL, SLS
     1, SPR, SU, SUS, XNOISE, ZNOISE, NF
      COMMON / ZON / ABPS(7), CREL(7), EFF(7), FLDST(7), GRLOS(7),
     1 HN(7), HP(7), PROB(7), RELY(7), RGAIN(7), SIGPOW(7), SN(7),
     2 SPRO(7), TGAIN(7), TIMED(7), TLOSS(7), B(7), FSLOS(7), ADV(7),
     3 OBF(7),NMODE(7),TLLOW(7),TLHGH(7)
      COMMON / FILES / LUI, LUO, LU2, LU5, LU6, LU15, LU16, LU20, LU25,
     A LU26, LU35
      COMMON/INFORM/INFO,IHSHR,IHLNG
      COMMON / PSCA / PSC(4), PSCB(4), IPSC
      DIMENSION IWCRD(100),xmonth(12)
      CHARACTER INAME1*8, INAME2*8, JNAME1*8, JNAME2*8, IOFF*3,
     A IBLANK*1, ITEMP*10, ISLAT*1, ISLONG*1, ISGLAT*1
      CHARACTER INORTH*1,IEAST*1,ISOUTH*1,IWEST*1
      CHARACTER NAMES*10, LABEL*5,
     A LAYTYP*2, LABLI*5, LABLJ*5, LABLK*5
      DATA INAME1/'BOULDER,'/, INAME2/' COLO.  '/, JNAME1/'ST. LOUI'/,
     A JNAME2/'S, MO.  '/
      DATA IWCRD/100*1/,
     A IOFF/'OFF'/, IBLANK/' '/
C***********************************************************************
C
C     SUBROUTINE REDMAP MAY READ THE IONOSPHERIC LONG TERM DATA BASE
C     FILE (LU2) DEPENDENT ON TASK OPTION AND USER DEFINED INPUT
C     THE PROGRAM WILL TERMINATE IF AN ERROR OCCURS (SET ITRUN = 0)
C
C     ON THE FIRST CALL TO THIS SUBROUTINE CONTROL PASSES TO STATEMENT
C     LABEL  90 TO READ THE FIRST CONTROL CARD FROM LUI WHICH INITIALLY
C     IS SET TO LU5.  CONTROL THEN PASSES TO STATEMENT LABEL 105 TO
C     BRANCH AND PROCESS THE CONTROL CARD.
C
C***********************************************************************

c jw      nch_run=lcount(run_directory,50)
C.....EXECUTE PROGRAM IF TWO CONSECUTIVE CARDS WITH SAME NAME
      IF(IRED.le.0) go to 105
   90 CONTINUE
C.....IF ISPROC = 0, CARDS ARE INPUT FROM THE USER DEFINED FILE (LUI)
C.....IF ISPROC = 1, CARDS ARE INPUT FROM THE PROCEDURE FILE (LU35)
      IF(ISPROC.gt.0) then
         ICARD = MONITR(LU35,MAXNAM)     !  read from procedure file
      else
         ICARD = MONITR(LUI,MAXNAM)      !  read from LUI
      end if
ccc      write(*,'(''  after monitr='',i3,''  maxnum,numnam='',2i5)')
ccc     +                icard,maxnum,numnam
      IF(LUI.ne.LU15) KCARD=KCARD+1
C.....ICARD IS AN INDEX OF THE CARD NAME
  105 IF(ICARD.GT.MAXNAM) GO TO 910
      IF(ICARD.GT.NUMNAM) GO TO 880
C.....ICARD = 1   2   3   4   5   6   7   8   9  10  11  12  13  14  15
C            16  17  18  19  20  21  22  23  24  25  26  27  28  29  30
C            31  32  33  34  35  36  37  38  39  40  41  42  43  44  45
C
C           MET MON MON SUN CIR SYS TIM CCI FRE LAB INT EXE SAM EFV ESV
C           EDP AUX AUX ANT OUT COM FRE PRO END NEX QUI FPR TOP BOT INF
C           ARE LIN COE ZON
C
ccc      write(*,'('' before GO TO (..) icard='',i5)') icard
      GO TO(110,145,165,205,230,270,285,330,340,380,390,410,425,465,480,
     A      490,505,515,525,535,545,550,560,625,635,670,700,750,770,780,
     B      800,805,806,810,820), ICARD
C***********************************************************************
C     METHOD CARD                                             ICARD = 1
C***********************************************************************
C.....THE METHOD CARD IS USED FOR PROGRAM CONTROL
  110 IF(IWCRD(1).le.0) go to 900
      READ(INPUT,1500) METHOD, NPAGO, MSPEC
c          PCVOACAP cannot use MSPEC=125
      if(METHOD.gt.200) then
         i_S_to_I=1             !  S/I calculations
         METHOD=METHOD-200
      else if(METHOD.gt.100) then
         iarea=1                !  area coverage
         METHOD=METHOD-100
      end if
      if(MSPEC.eq.125 .and. model.eq.'PCVOACAP') MSPEC=0
      if(METHOD.eq.30) then            !  Short/Long Path smoothing
         MSPEC=121
         METHOD=20
      end if
C.....TERMINATE EXECUTION IF METHOD .LE. 0 OR .GT. MAXIMUM METHOD
C.....HOWEVER, A "QUIT" CARD IS REQUIRED AS THE LAST CONTROL CARD
      IF(METHOD.le.MAXMET) go to 125
      ITRUN = 0
      ITOUT = 0
      GO TO 920
C.....SET RUN AND OUTPUT INDICATORS DEPENDING ON METHOD
  125 ITRUN = JTRUN(METHOD)
      ITOUT = JTOUT(METHOD)
C.....SET STARTING PAGE NUMBER FOR OUTPUT FILE
      IF(NPAGO.gt.0) LPAGES = NPAGO-1
      IWCRD(1) = -1
      GO TO 90
C***********************************************************************
C     MONTH CARD                                              ICARD = 2
C***********************************************************************
  145 IF(IWCRD(2).le.0) go to 900
ccc      READ(INPUT,1502) NYEAR, (MONTHS(I),I=1,12)
      READ(INPUT,'(10x,a5,13f5.2)') NYEAR, (XMONTH(I),I=1,12)
      do 146 i=1,12
      if(xmonth(i).lt..005) then          !  no  month
         months(i)=0
         idaily(i)=0
      else if(xmonth(i).lt.1.) then       !  old month
         months(i)=nint(xmonth(i)*100.)
         idaily(i)=0
      else                                !  month.day
         monthx=xmonth(i)
         ida=nint((xmonth(i)-float(monthx))*100.)
         idaily(i)=ida                    !  if <>0, use daily foF2 coeff
         months(i)=monthx
         if(ida.gt.0) then
            if (coeff.eq.'CCIR') then
              write(*,'('' *******************************************************'')')
              write(*,'('' * Warning: Daily predictions specified in input file. *'')')
              write(*,'('' * forcing use of URSI coefficients.                   *'')')
              write(*,'('' *******************************************************'')')
            end if
            coeff='URSI'                  !  daily MUST use URSI
         end if
      end if
146   continue

      IWCRD(2) = -1
      GO TO 90
C***********************************************************************
C     MONTHLOOP CARD                                          ICARD = 3
C***********************************************************************
  165 continue
      pause 'MONTHLOOP card no longer valid in VOACAP'
      stop  'MONTHLOOP card no longer valid in VOACAP'
C***********************************************************************
C     SUNSPOT CARD                                            ICARD = 4
C***********************************************************************
  205 IF(IWCRD(4).le.0) go to 900
      READ(INPUT,1508) (SUNSP(I),I=1,12)
      IWCRD(4) = -1
      go to 90
C***********************************************************************
C     CIRCUIT CARD                                            ICARD = 5
C***********************************************************************
  230 IF(IWCRD(5).le.0) go to 900
      READ(INPUT,1506) TLATD,ITLAT, TLONGD, ITLONG, RLATD, IRLAT,
     A RLONGD, IRLONG, NPSL
 1506 FORMAT(10X,F5.2,A1,3(F9.2,A1),4X,I5)
      IWCRD(5) = -1
      IF(ITLAT .EQ. IBLANK) GO TO 255
      IF(ITLONG .EQ. IBLANK) GO TO 255
      IF(IRLAT .EQ. IBLANK) GO TO 255
      IF(IRLONG .NE. IBLANK) GO TO 260
C.....CIRCUIT TRANSMITTER AND RECEIVER COORDINATES ARE BLANK
C.....SET COORDINATES TO THE FOLLOWING DEFAULT CIRCUIT
C.....BOULDER, COLORADO TO ST. LOUIS, MO.
  255 TLATD = 40.03
      ITLAT = INORTH
      TLONGD = 105.3
      ITLONG = IWEST
      RLATD = 38.67
      IRLAT = INORTH
      RLONGD = 90.25
      IRLONG= IWEST
      ITRAN(1) = INAME1
      ITRAN(2) = INAME2
      IRCVR(1) = JNAME1
      IRCVR(2) = JNAME2
C.....OUTPUT IN GEOM
  260 CONTINUE
      if(ITLAT.eq.ISOUTH) TLATD=-TLATD
      if(ITLONG.eq.IWEST) TLONGD=-TLONGD
      if(IRLAT.eq.ISOUTH) RLATD=-RLATD
      if(IRLONG.eq.IWEST) RLONGD=-RLONGD
      GO TO 90
C***********************************************************************
C     SYSTEM CARD                                             ICARD = 6
C***********************************************************************
  270 IF(IWCRD(6).le.0) go to 900
      READ(INPUT,1507) PWX, XNOISE, AMIND, XLUFP, RSNX, PMPX, DMPX
 1507 FORMAT(10X,F5.2,F5.0,F5.2,F5.0,3F5.2)
C.....SET VARIABLES TO DEFAULT VALUES IF NOT SET ON SYSTEM CARD
      IWCRD(6) = -1
      IF(XNOISE.NE.0.) NOISE = XNOISE
      LUFP = XLUFP
      IF(AMIND.LE.0.0) AMIND = 3.0
      AMIN = AMIND * D2R
      IF(LUFP.LE.0) LUFP = 90.
ccc      IF(RSNX.GT.0.) RSN = RSNX
ccc      IF(PMPX.NE.0.) PMP = PMPX
ccc      IF(DMPX.NE.0.) DMP = DMPX
      RSN = RSNX
      PMP = PMPX
      DMP = DMPX
      GO TO 90
C***********************************************************************
C     TIME CARD                                               ICARD = 7
C***********************************************************************
  285 IF(IWCRD(7).le.0) go to 900
      READ(INPUT,1500) IHRO, IHRE, IHRS, ITIM
      IWCRD(7) = -1
C.....SET HOUR INCREMENT TO THE DEFAULT VALUE OF ONE (IF .LE. 0)
      IF(IHRS.LE.0) IHRS = 1
c          New TIME concept by Greg Hand 5/17/93
c          Time may now run around midnight (e.g. 22 to 04)
      istart=IHRO
      if(istart.eq.0) istart=24
      iend=IHRE
      if(IHRE.lt.istart) iend=iend+24
      nhours=0
      do 287 ihr=istart,iend,IHRS
      jhr=ihr
      if(jhr.gt.24) jhr=jhr-24
      nhours=nhours+1
287   ihours(nhours)=jhr
      GO TO 90
C***********************************************************************
C     ANTENNA CARD                                            ICARD = 8
C***********************************************************************
  330 CONTINUE
      READ(INPUT,1510) IAT,iantr,minfreq,maxfreq,designfreq(iantr),
     +                 antfile(iantr),beammain(iantr),pwrkw(iantr)
 1510 FORMAT(10X,4I5,f10.3,1x,a21,1x,f5.1,f10.4)
      iats(iantr)=iat
      if(iat.eq.1) then             !  transmitter, save power
         if(pwrkw(iantr).le.0.) pwrkw(iantr)=1.
         pwrdba(iantr)=30. + 10.*alog10(pwrkw(iantr))    !  convert to dB
      end if
      if(iantr.gt.numants) numants=iantr
      write(gainfile,'(4hgain,i2.2,4h.dat)') iantr
ccc      write(*,'('' opening file='',a)') run_directory(1:nch_run)//
ccc     +                                         '\'//gainfile
      open(lu26,file=trim(run_directory)//PATH_SEPARATOR//gainfile,status='old',form='formatted')
      rewind(lu26)
      read(lu26,331) anttype(iantr),antname(iantr)
331   format(a10,a70)
      read(lu26,332) xfqs(iantr),xfqe(iantr),
     +           beammain(iantr),offazim(iantr),cond(iantr),diel(iantr)
332   format(2f5.0,2f7.2,2f10.5)
      if(offazim(iantr).eq.-999.) then      !  area coverage
c          change made 8/31/95 for Windows version because gains are
c          stored in the correct arrays in antcalc
ccc         read(lu26,'(25x,f10.3)') aeff(1,iantr)
ccc         do 334 iazim=1,360
ccc         read(lu26,333) (array91(ielev),ielev=1,91)
ccc333      format(9x,10f7.3)
ccc         do 334 ielev=1,91              !  store in INTEGER*2 to save space
ccc         gain=array91(ielev)
ccc         if(gain.gt. 300.) gain= 300.
ccc         if(gain.lt.-300.) gain=-300.
ccc334      iarray360(iazim,ielev,iantr)=gain*100.
      else
         do 335 ifreq=1,30
335      read(lu26,336) AEFF(ifreq,iantr),(array(ifreq,j,iantr),j=1,91)
336      format(2x,f6.2,(t10,10f7.3))
      end if
      close(lu26)
      GO TO 90
C***********************************************************************
C     FREQUENCY CARD                                          ICARD = 9
C***********************************************************************
  340 IF(IWCRD(9).le.0) go to 900
      if(INPUT(11:11).eq.'$') then           !  get 3 sig digits in frequency
         READ(INPUT,341) (FREL(IFK),IFK=1,11)
341      format(11x,11f6.3)
      else
         READ(INPUT,1508) (FREL(IFK),IFK=1,11)
      end if
      IWCRD(9) = -1
C.....SET REST OF FREQUENCY ARRAY
      DO 350 IFK = 12,29
  350 FREL(IFK) = 0.
C.....SET FREL(14) AS A FLAG
      IF(FREL(1).eq.0.) then
         IF(FREL(2).le.0.) then
C.....SET FLAG TO CALCULATE FREQUENCY COMPLEMENT IN FRQCOM EACH HOUR
            FREL(14) = -1.
         else
C.....SET FLAG TO USE FOT AS FIRST FREQUENCY FOR EACH HOUR
            FREL(14) = -10.
         end if
      else
C.....SET FLAG TO USE INPUT DATA
         FREL(14) = 1.
      end if
      GO TO 90
C***********************************************************************
C     LABEL CARD                                              ICARD = 10
C***********************************************************************
  380 IF(IWCRD(10)) 900, 900, 385
  385 READ(INPUT,1504) ITRAN(1), ITRAN(2), IRCVR(1), IRCVR(2)
      IWCRD(10) = -1
      GO TO 90
C***********************************************************************
C     INTEGRATE CARD                                          ICARD = 11
C***********************************************************************
C.....THE "INTEGRATE" CARD INDICATES WHAT KIND OF INTEGRATION IS USED
C.....INTEG = -1 FOR ALWAYS GAUSSIAN,
C.....INTEG .GE. 0 FOR MODEL SEGMENT WHEN NO F1 LAYER
  390 CONTINUE
      READ(INPUT,1504) ITEMP
      INTEG = 1
      IEDP = 1
      IF(ITEMP .EQ. IOFF) GO TO 90
      READ(INPUT,1500) INTEG
      IEDP = INTEG
      GO TO 90
C***********************************************************************
C     EXECUTE CARD                                            ICARD = 12
C***********************************************************************
C.....THE "EXECUTE" CARD CAUSES PROGRAM EXECUTION
  410 READ(INPUT,1500) KRUN
      IRED = 1
  415 DO 420 IC = 1,MAXNAM
  420 IWCRD(IC) = 1
      GO TO 920
C***********************************************************************
C     SAMPLE CARD                                             ICARD = 13
C***********************************************************************
C.....SAMPLE FOR GEOGRAPHICAL VARIABLES
  425 CONTINUE
C.....THE USER MAY RUN METHOD= 1 TO OBTAIN THESE VALUES FROM THE
C.....IONOSPHERIC LONG TERM DATA BASE FILE (LU2) . HE MAY THEN PUNCH THE
C.....VALUES ON DATA CARDS INSTEAD OF READING THE DATA BASE FILE.
  430 READ(INPUT,1514) I, SLAT, ISLAT, SLONG, ISLONG, SGLAT,
     A ISGLAT, RD(I), GYZ(I), CLCK(I), GMDIP(I), ARTIC(I), SIGPAT(I),
     B EPSPAT(I)
      IF(ISLAT .EQ. ISOUTH) SLAT = -SLAT
      CLAT(I) = SLAT * D2R
      IF(ISLONG .EQ. IWEST) SLONG = -SLONG
      CLONG(I) = SLONG * D2R
      IF(ISGLAT .EQ. ISOUTH) SGLAT = -SGLAT
      GLAT(I) = SGLAT * D2R
      GO TO 90
C***********************************************************************
C     EFVAR CARD                                              ICARD = 14
C***********************************************************************
C.....SAMPLE FOR E, F1, F2 LAYERS, FREQ, SEMI-THICKNESS, HEIGHT OF MAX
  465 CONTINUE
C.....THE USER MAY RUN METHOD= 1 TO OBTAIN THESE VALUES FROM THE
C.....IONOSPHERIC LONG TERM DATA BASE FILE (LU2) . HE MAY THEN PUNCH THE
C.....VALUES ON DATA CARDS INSTEAD OF READING THE DATA BASE FILE.
  470 READ(INPUT,1516) I,(FI(J,I), YI(J,I), HI(J,I),J=1,3)
      F2M3(I) = 1490. / (HI(3,I) + 176.)
      HPF2(I) = HI(3,I)
      GO TO 90
C***********************************************************************
C     ESVAR CARD                                              ICARD = 15
C***********************************************************************
C.....SAMPLE FOR ES LAYER, LOW, MIDDLE, HIGH, VIRTUAL HEIGHT
  480 CONTINUE
C.....THE USER MAY RUN METHOD= 1 TO OBTAIN THESE VALUES FROM THE
C.....IONOSPHERIC LONG TERM DATA BASE FILE (LU2) . HE MAY THEN PUNCH THE
C.....VALUES ON DATA CARDS INSTEAD OF READING THE DATA BASE FILE.
  485 READ(INPUT,1518) I, FS(1,I), FS(2,I), FS(3,I), HS(I)
      GO TO 90
C***********************************************************************
C     EDP CARD                                                ICARD = 16
C***********************************************************************
C.....THE "EDP" CARD ALLOWS THE USER TO READ IN AND USE AN EXTERNAL
C.....ELECTRON DENSITY PROFILE FOR A SPECIFIED SAMPLE AREA
C.....(FOR ONE HOP PATH ONLY)
  490 CONTINUE
      READ(INPUT,1530) JSAMP, ITEMP
C.....ASSUME THE DEFAULT SAMPLE AREA = 1
C.....IF THE SPECIFIED SAMPLE AREA ISN"T 1, 2 OR 3
      IF(JSAMP) 494, 494, 492
  492 IF(JSAMP - 3) 496, 496, 494
  494 JSAMP = 1
  496 IF(ITEMP .NE. IOFF) GO TO 500
C.....USE THE INTERNAL ELECTRON DENSITY PROFILE INSTEAD OF THE ONE READ
      IELECT(JSAMP) = 0
      GO TO 90
C.....READ THE EXTERNAL ELECTRON DENSITY PROFILE
  500 IELECT(JSAMP) = 1
C.....N O T E    CHANGED TO HTR(50,3) AND FNSQ(50,3)
      READ(LUI,1528) (HTR(I,1),I=1,50)
      READ(LUI,1528) (FNSQ(I,1),I=1,50)
      GO TO 90
C***********************************************************************
C     AUXIN CARD                                              ICARD = 17
C***********************************************************************
C.....THE "AUXIN" CARD CAUSES INPUT CARD IMAGES TO BE READ FROM THE
C.....AUXILLARY INPUT FILE
  505 CONTINUE
      READ(INPUT,1504) ITEMP
      LUI = LU15
      IF(ITEMP .NE. IOFF) GO TO 90
      LUI = LU5
      GO TO 90
C***********************************************************************
C     AUXOUT CARD                                             ICARD = 18
C***********************************************************************
C.....THE "AUXOUT" CARD CAUSES THE OUTPUT FILE TO BE CHANGED FROM THE
C.....STANDARD OUTPUT FILE TO THE ALTERNATE OUTPUT FILE
  515 CONTINUE
      READ(INPUT,1504) ITEMP
      LUO = LU16
      IF(ITEMP .NE. IOFF) GO TO 90
      LUO = LU6
      GO TO 90
C***********************************************************************
C     ANTOUT CARD                                             ICARD = 19
C***********************************************************************
C.....THE "ANTOUT" CARD INDICATES THE ANTENNA PATTERNS CREATED
C.....ARE TO BE WRITTEN ON A FILE FOR LATER USE
  525 CONTINUE
      READ(INPUT,1504) ITEMP
      IANTOU = 1
      IF(ITEMP .NE. IOFF) GO TO 90
      IANTOU = 0
      GO TO 90
C***********************************************************************
C     OUTGRAPH CARD                                           ICARD = 20
C***********************************************************************
C.....THE "OUTGRAPH" CARD ALLOWS THE USER TO REQUEST OUTPUT OF SEVERAL
C.....DIFFERENT METHODS THAT HAVE OUTPUT OPTIONS 3 OR 4
  535 CONTINUE
      READ(INPUT,1504) ITEMP
      ISOUT = 0
      IF(ITEMP .EQ. IOFF) GO TO 90
      ISOUT = 1
      READ(INPUT,1500) KTOUT
      GO TO 90
C***********************************************************************
C     COMMENT CARD                                            ICARD = 21
C***********************************************************************
C.....THE "COMMENT" CARD ALLOWS THE USER TO PUT COMMENTS IN THE INPUT
C.....FILE. IT HAS NO EFFECT ON PROGRAM EXECUTION
  545 CONTINUE
      if(input(11:14).eq.'GROU') write(LUO,'(11h COMMENT   ,a)')
     +        input(11:)
      GO TO 90
C***********************************************************************
C     FREEFORM                                                ICARD = 22
C***********************************************************************
C.....THE "FREEFORM" CARD INDICATES THAT THE INPUT CONSISTES OF
C.....FREEFORM CARD IMAGES
C     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
C     N O T E - THE FREEFORM INPUT ANALYSER IS NOT YET DEVELOPED
C     XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
  550 CONTINUE
      READ(INPUT,1504) ITEMP
      ITYPE = 1
      IF(ITEMP .NE. IOFF) GO TO 90
      ITYPE = 0
      GO TO 90
C***********************************************************************
C     PROCEDURE CARD                                          ICARD = 23
C***********************************************************************
C.....THE "PROCEDURE" CARD ALLOWS THE USER TO DEFINE A PROCEDURE
C.....THE PROCEDURE IS STORED ON LU35 AND WHEN A CALL TO THE PROCEDURE
C.....OCCURS (IE THE USER SPECIFIES THE NAME OF THE PROCEDURE ON AN
C.....INPUT CARD) THE PROGRAM READS THE PROCEDURE FILE AND REPLACES
C.....THE PROCEDURE CALL WITH THE PROCEDURE DEFINITION
  560 CONTINUE
C.....PROCEDURE FILE HAS ALREADY BEEN CREATED IN SUBROUTINE LISTIN
C.....IGNORE THE PROCEDURE DEFINITION ON THE INPUT FILE
  590 JCARD = MONITR(LUI,MAXNAM)
      KCARD = KCARD + 1
C.....SKIP PAST THE "END" CARD
      IF(JCARD - 24) 590, 90, 590
C***********************************************************************
C     END CARD                                                ICARD = 24
C***********************************************************************
C.....THE "END" CARD IS USED TO END A PROCEDURE DEFINITION
  625 CONTINUE
      ISPROC = 0
      GO TO 90
C***********************************************************************
C     NEXT CARD                                               ICARD = 25
C***********************************************************************
C.....THE "NEXT" CARD TERMINATES A MONTH SUNSPOT LOOP
  635 CONTINUE
      pause 'NEXT card no longer valid in VOACAP'
      stop  'NEXT card no longer valid in VOACAP'
ccc      GO TO 90
C***********************************************************************
C     QUIT CARD                                               ICARD = 26
C***********************************************************************
C.....THE "QUIT" CARD IS USED TO TERMINATE PROGRAM EXECUTION
  670 CONTINUE
      ITRUN = 0
      GO TO 920
C***********************************************************************
C     FPROB CARD                                              ICARD = 27
C***********************************************************************
C.....THE "FPROB" CARD ALLOWS THE USER TO ALTER THE PREDICTED CRITICAL
C.....FREQUENCIES. EACH CRITICAL FREQUENCY IS MULTIPLIED BY PSC(N),
C.....WHERE N = 1 IS E, N=2 IS F1, N=3 IS F2 AND N=4 IS ES.
C.....(N O T E -  E AND F2 ARE NECESSARY)
  700 CONTINUE
      READ(INPUT,1504) ITEMP
      IF(ITEMP .EQ. IOFF) GO TO 720
      IPSC = 1
      READ(INPUT,1508) PSC
      IF(PSC(1).LE.0.) PSC(1) = PSCB(1)
      IF(PSC(2).LT.0.) PSC(2) = PSCB(2)
      IF(PSC(3).LE.0.) PSC(3) = PSCB(3)
      IF(PSC(4).LT.0.) PSC(4) = PSCB(4)
      GO TO 90
  720 IPSC = 0
      DO 730 I = 1,4
  730 PSC(I) = PSCB(I)
      GO TO 90
C***********************************************************************
C     TOPLINES CARD                                           ICARD = 28
C***********************************************************************
C.....THE "TOPLINES" CARD ALLOWS THE USER TO SPECIFY THE LINES PRINTED
C     IN SUBROUTINE OUTTOP (WHENEVER METHOD = 23)
  750 CONTINUE
      READ(INPUT,1504) ITEMP
      LINTYP = 0
      IF(ITEMP .EQ. IOFF) GO TO 90
      LINTYP = 1
      READ(INPUT,1500) LINTP
      GO TO 90
C***********************************************************************
C     BOTLINES CARD                                           ICARD = 29
C***********************************************************************
C.....THE "BOTLINES" CARD ALLOWS THE USER TO SPECIFY THE LINES PRINTED
C     IN SUBROUTINE OUTBOD (WHENEVER METHOD = 23)
  770 CONTINUE
      READ(INPUT,1504) ITEMP
      LINBYP = 0
      IF(ITEMP .EQ. IOFF) GO TO 90
      LINBYP = 1
      READ(INPUT,1500) LINBD
      GO TO 90
C***********************************************************************
C     INFORMATION CARD                                        ICARD = 30
C***********************************************************************
C     N O T E - THIS OPTION IS NOT AVAILABLE TO ALL USERS AND IF NOT
C     AVAILABLE ACTS AS A "DO-NOTHING" CARD AND IS IGNORED
C
C     1.  MODE GENERATION SUBROUTINE.                     SHORT
C     2.  OVER-THE-MUF ABSORPTION RATES.                  BOTH
C     4.  SELTXR (0.05 to 0.5) CHANGE RESULTS.            LONG
C         or LUCAS' LETTER FOR HIGH ORDER MUFS ONLY       SHORT
C     8.  LUCAS' LETTER CHANGE RESULTS.                   BOTH
C    16.  LONG PATH/SHORT PATH SMOOTHING VALUES.          BOTH (MSPEC=121)
C    32.  RAYSET (PAGE 23)                                BOTH
C    64.  V. IONOGRAM AND REFLECTRIX (PAGE 21)            BOTH
C   128.  EXTRA LONG PATH PARAMETERS                      LONG
C
  780 READ(INPUT,1500)INFO
      IHSHR=IAND(INFO,1)+IAND(INFO,2)+IAND(INFO,32)+IAND(INFO,128)
      IHLNG=IAND(INFO,2)+IAND(INFO,8)+IAND(INFO,32)+IAND(INFO,128)
            GO TO 90
C***********************************************************************
C     AREA    CARD                                            ICARD = 31
C***********************************************************************
C.....AREA    card reads area coverage center and limits
800   nx=0
      ny=0
      READ(INPUT,801) plat,plon,xmin,xmax,yymin,ymax,nx,ny,itype
801   format(10x,6F10.0,3i5)
      if(nx.eq.0) nx=5
      if(ny.eq.0) ny=5
      iproj=7               !  great circle projection
      if(itype.ne.0) iproj=8         !  lat/lon for GRIB format
      iarea=1
      GO TO 90
C***********************************************************************
C     LINEMAX CARD                                            ICARD = 32
C***********************************************************************
C.....LINEMAX card reads maximum lines per page
805   READ(INPUT,'(10x,i5)') LINMAX
      if(LINMAX.lt.30) LINMAX=55
      GO TO 90
C***********************************************************************
C     COEFFS  CARD                                            ICARD = 33
C***********************************************************************
C.....COEFFS card allows either CCIR or URSI88 foF2 coefficients
806   coeff=INPUT(11:14)
      if(coeff.ne.'URSI') coeff='CCIR'
      GO TO 90
C***********************************************************************
C     (ZONES) CARD                                            ICARD = 34
C***********************************************************************
C.....CIRAF zone list to calculate values at CIRAF test points
  810 CONTINUE
      call rdCIRAF           !  read the 911 CIRAF test points
      cirafz=input(11:40)
      call parse_zones(cirafz,zones,nzones)
      call zones_to_TP(zones,nzones,idx_TP,nTP)  !  convert zones to Test Points
      GO TO 90
C***********************************************************************
C     (BLANK) CARD                                            ICARD = 35
C***********************************************************************
C.....A "(BLANK)" CARD ACTS AS A "DO-NOTHING" CARD AND IS IGNORED
  820 CONTINUE
      GO TO 90
C***********************************************************************
C     (USER DEFINED PROCEDURE NAME) CARD
C***********************************************************************
C.....THE "(USER DEFINED PROCEDURE NAME)" CARD PLACES THE CARD IMAGES
C     DEFINED BY THE USER PROCEDURE INTO THE INPUT STREAM
  880 CONTINUE
      REWIND LU35
      ISPROC = 1
C.....LOCATE THE DESIRED PROCEDURE ON THE PROCEDURE FILE
  890 JCARD = MONITR(LU35,MAXNAM)
      IF(JCARD - ICARD) 890, 90, 890
C.....END OF NAMES
C.....EXECUTE PROGRAM IF TWO CONSECUTIVE CARDS WITH THE SAME NAME
  900 CONTINUE
      IRED = -1
      GO TO 415
C.....E R R O R IN THE INPUT - CARD NAME NOT FOUND IN THE CARD NAME LIST
  910 WRITE(LUO,1520)
      ITRUN = 0
  920 continue
      do 930 i=1,12   !  if any daily predictions, must use URSI
         if(idaily(i).ne.0) then
            coeff='URSI'
         end if
930   continue
      RETURN
C.....FORMAT SPECIFICATIONS
 1401 FORMAT(A80)
 1402 FORMAT(' ','MONTH =',I5,5X,'MONTH INDEX =',I5)
 1403 FORMAT(' ',8A10,5X,'ICARD = ',I5)
 1406 FORMAT(' ','SSN = ',F7.2)
 1500 FORMAT(10X,14I5)
 1502 FORMAT(10X,A5,13I5)
 1504 FORMAT(10X,4A10)
 1508 FORMAT(10X,13F5.2)
 1514 FORMAT(10X,I5,3(F5.2,A1,4X),F5.0,6F5.2)
 1516 FORMAT(10X,I5,3(F5.2,2F5.1))
 1518 FORMAT(10X,I5,3F5.2,F5.1)
 1520 FORMAT(///,' NAME IDENTIFIER ERRORS DETECTED ON INPUT FILE')
 1528 FORMAT(16F5.2)
 1530 FORMAT(10X,I5,A10)
      END
C--------------------------------


subroutine z_drychk(idry      ,j         ,nmmaxj    ,nmmax     ,kmax      , &
                  & nfltyp    ,icx       ,icy       ,kfu       ,kfv       , &
                  & kfs       ,kcs       ,kfuz0     ,kfvz0     ,kfsz1     , &
                  & kfsmin    ,kfsmn0    ,kfsmax    ,kfsmx0    ,s1        , &
                  & r1        ,dps       ,qxk       ,qyk       ,w1        , &
                  & lstsci    ,dzs1      ,zk        ,nst       ,gdp       )
!----- GPL ---------------------------------------------------------------------
!
!  Copyright (C)  Stichting Deltares, 2011-2016.
!
!  This program is free software: you can redistribute it and/or modify
!  it under the terms of the GNU General Public License as published by
!  the Free Software Foundation version 3.
!
!  This program is distributed in the hope that it will be useful,
!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!  GNU General Public License for more details.
!
!  You should have received a copy of the GNU General Public License
!  along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!  contact: delft3d.support@deltares.nl
!  Stichting Deltares
!  P.O. Box 177
!  2600 MH Delft, The Netherlands
!
!  All indications and logos of, and references to, "Delft3D" and "Deltares"
!  are registered trademarks of Stichting Deltares, and remain the property of
!  Stichting Deltares. All rights reserved.
!
!-------------------------------------------------------------------------------
!  $Id: z_drychk.f90 5717 2016-01-12 11:35:24Z mourits $
!  $HeadURL: https://svn.oss.deltares.nl/repos/delft3d/tags/6686/src/engines_gpl/flow2d3d/packages/kernel/src/compute/z_drychk.f90 $
!!--description-----------------------------------------------------------------
!
!    Function: This subroutine checks for drying in water level
!              points. In case the point is dry, all surrounding
!              mask arrays (KFU and KFV) are set to zero and sub-
!              sequently SUD computation will be repeated
! Method used:
!
!!--pseudo code and references--------------------------------------------------
! NONE
!!--declarations----------------------------------------------------------------
    use precision
    use dfparall
    !
    use globaldata
    !
    implicit none
    !
    type(globdat),target :: gdp
    !
    ! The following list of pointer parameters is used to point inside the gdp structure
    !
    integer  , pointer :: lundia
    real(fp) , pointer :: dzmin
!
! Global variables
!
    integer                                             , intent(in)  :: icx    !  Increment in the X-dir., if ICX= NMAX then computation proceeds in the X-dir. If icx=1 then computation proceeds in the Y-dir.
    integer                                             , intent(in)  :: icy    !  Increment in the Y-dir. (see ICX)
    integer                                             , intent(out) :: idry   !  Flag set to 1 if a dry point is detected in routine DRYCHK after SUD is completed
    integer                                                           :: j      !  Begin pointer for arrays which have been transformed into 1D arrays. Due to the shift in the 2nd (M-) index, J = -2*NMAX + 1
    integer                                             , intent(in)  :: kmax   !  Description and declaration in esm_alloc_int.f90
    integer                                                           :: lstsci !  Description and declaration in esm_alloc_int.f90
    integer                                                           :: nfltyp !  Description and declaration in esm_alloc_int.f90
    integer                                             , intent(in)  :: nmmax  !  Description and declaration in dimens.igs
    integer                                                           :: nmmaxj !  Description and declaration in dimens.igs
    integer                                                           :: nst    !  Time step number
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: kcs    !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)                      :: kfs    !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)                      :: kfsmax !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)                      :: kfsmin !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)                      :: kfsmx0 !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)                      :: kfsmn0 !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)                      :: kfu    !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub)                      :: kfv    !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)  , intent(out) :: kfsz1  !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)  , intent(out) :: kfuz0  !  Description and declaration in esm_alloc_int.f90
    integer   , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)  , intent(out) :: kfvz0  !  Description and declaration in esm_alloc_int.f90
    real(prec), dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: dps    !  Description and declaration in esm_alloc_real.f90
    real(fp)  , dimension(gdp%d%nmlb:gdp%d%nmub, kmax, lstsci)        :: r1     !  Description and declaration in esm_alloc_real.f90
    real(fp)  , dimension(gdp%d%nmlb:gdp%d%nmub)        , intent(in)  :: s1     !  Description and declaration in esm_alloc_real.f90
    real(fp)  , dimension(gdp%d%nmlb:gdp%d%nmub, 0:kmax)              :: w1     !  Description and declaration in esm_alloc_real.f90
    real(fp)  , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)  , intent(out) :: dzs1   !  Description and declaration in esm_alloc_real.f90
    real(fp)  , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)  , intent(out) :: qxk    !  Description and declaration in esm_alloc_real.f90
    real(fp)  , dimension(gdp%d%nmlb:gdp%d%nmub, kmax)  , intent(out) :: qyk    !  Description and declaration in esm_alloc_real.f90
    real(fp)  , dimension(0:kmax), intent(in) :: zk
!
! Local variables
!
    integer                :: k
    integer                :: l
    integer                :: ndm
    integer                :: nm
    integer                :: nmd
    integer                :: nm_pos    ! indicating the array to be exchanged has nm index at the 2nd place, e.g., dbodsd(lsedtot,nm)
    integer, dimension(1)  :: nm_s1max1
    integer, dimension(1)  :: nm_s1max2
    logical                :: flood
    logical                :: zmodel
    real(fp)               :: s1max1
    real(fp)               :: s1max2
    real(fp)               :: zdiff
    character(300)         :: errmsg
!
!! executable statements -------------------------------------------------------
!
    lundia  => gdp%gdinout%lundia
    dzmin   => gdp%gdzmodel%dzmin
    !
    idry   = 0
    nm_pos = 1
    !
    do nm = 1, nmmax
       nmd = nm - icx
       ndm = nm - icy
       if ( (kcs(nm)==1 .or. kcs(nm)==2) ) then
          !
          ! Check on kfs(nm) == 1 is necessary, because when the last active cell edge of a cell
          ! was set dry in Z_SUD, all KFU/KFV are zero and this check would not be performed
          !
          if (kfu(nm)==1 .or. kfu(nmd)==1 .or. kfv(nm)==1 .or. kfv(ndm)==1 .or. kfs(nm)==1) then
             if ( s1(nm) <= -real(dps(nm),fp) ) then
                kfu(nm ) = 0
                kfu(nmd) = 0
                kfv(nm ) = 0
                kfv(ndm) = 0
                do k = 1, kmax  ! evt. kfsmin, kmax
                   kfuz0(nm , k) = 0
                   kfuz0(nmd, k) = 0
                   kfvz0(nm , k) = 0
                   kfvz0(ndm, k) = 0
                   qxk  (nm , k) = 0.0_fp
                   qxk  (nmd, k) = 0.0_fp
                   qyk  (nm , k) = 0.0_fp
                   qyk  (ndm, k) = 0.0_fp
                   dzs1 (nm , k) = 0.0_fp
                enddo
                !
                ! At least one cell that was active has become dry:
                ! Redo Z_SUD (from Z_ADI) with these cells isolated
                !
                idry = 1
             endif
          endif
       endif
    enddo
    !
    ! Determine global maximum of 'idry' over all nodes
    ! Note: this enables to synchronize the repeating computation of SUD
    !
    call dfreduce_gdp( idry, 1, dfint, dfmax, gdp )
    !
    ! CHECK FOR FOUR DRY VELOCITY POINTS
    !
    s1max1 = -999.0_fp
    s1max2 = -999.0_fp
    do nm = 1, nmmax
       !
       ! determination number of layers at old time level in case of flooding.
       !
       if (kcs(nm) > 0) then
          nmd = nm - icx
          ndm = nm - icy
          kfs(nm) = max(kfu(nm), kfu(nmd), kfv(nm), kfv(ndm))
       endif
       !
       if (kcs(nm) > 0) then
          !
          ! 15-3-2007 change to allow S1 > ZK(KMAX), needed for NH-models
          !
          if ( s1(nm) >= zk(kmax) ) then
             kfsmax(nm) = kmax
          else
             do k = kfsmin(nm), kmax
                if ( zk(k)+dzmin >= s1(nm) ) then
                   kfsmax(nm) = k
                   exit
                endif
             enddo
          endif
          !
          ! Find the (new) location of the bed layer
          !
          do k = 1, kmax
             if ( zk(k)-dzmin >= -real(dps(nm),fp) .or. k == kmax) then
                kfsmin(nm) = k
                exit
             endif
          enddo
          !
          ! determination number of layers at new time level
          !
          kfsz1(nm,:) = 0
          do k = kfsmin(nm), kfsmax(nm)
             kfsz1(nm, k) = kfs(nm)
          enddo
       endif
    enddo
    !
    ! Delft3D-16494: NOT NECESSARY?
    !
    ! Exchange mask array kfs with neighbours for parallel runs
    !
    call dfexchg ( kfs, 1,    1, dfint, nm_pos, gdp )
    !
    ! issue warning if maximum water level is above zk(kmax) (ZTOP)
    !
    s1max1    = maxval(s1)
    s1max2    = maxval(s1(1:nmmax))
    nm_s1max1 = maxloc(s1)
    nm_s1max2 = maxloc(s1(1:nmmax))
    kfsmax(nm_s1max1(1)) = max(kfsmax(nm_s1max1(1)),1)
    kfsmax(nm_s1max2(1)) = max(kfsmax(nm_s1max2(1)),1)
    if (s1max1 > zk(kmax)+0.5*(dzs1(nm_s1max1(1),kfsmax(nm_s1max1(1)))).and. kfs(nm_s1max1(1)) == 1) then
       write (errmsg, '(a,g10.3,2a,i0,a,i0,a,i0,2a)') '1: Maximum water level ', s1max1, &
                    & ', (m). Top layer is too thick. ',                                 &
                    & ', for nm = ', nm_s1max1, ', icx = ', icx,                         &
                    & ' and nst = ', nst,                                                &
                    & '; Changing ZTOP is strongly advised'
       call prterr(lundia, 'U190', trim(errmsg))
    endif
    !
    if (s1max2 > zk(kmax)+0.5*(dzs1(nm_s1max2(1),kfsmax(nm_s1max2(1)))).and. kfs(nm_s1max2(1)) == 1) then
       write (errmsg, '(a,g10.3,2a,i0,a,i0,a,i0,2a)') '2: Maximum water level ', s1max2, &
                    & ', (m). Top layer is too thick.',                                  &
                    & ', for nm = ', nm_s1max2, ', icx = ', icx,                         &
                    & ' and nst = ', nst,                                                &
                    & '; Changing ZTOP is strongly advised'
       call prterr(lundia, 'U190', trim(errmsg))
    endif
    !
    ! Recalculate DZS1
    ! Reset all DZS1 to for all inactive points above KFSMAX
    !
    do nm = 1, nmmax
       if (kcs(nm) /= 0) then
          do k = kfsmin(nm), kfsmax(nm)
             if (kfsmin(nm) == kfsmax(nm)) then
                dzs1(nm, k) = real(dps(nm),fp) + s1(nm)
             elseif (k == kfsmin(nm)) then
                dzs1(nm, k) = zk(k) + real(dps(nm),fp)
             elseif (k == kfsmax(nm)) then
                dzs1(nm, k) = s1(nm) - zk(k - 1)
             else
                dzs1(nm, k) = zk(k) - zk(k - 1)
             endif
          enddo
          do k = kfsmax(nm) + 1, kmax
             dzs1(nm, k) = 0.0_fp
          enddo
       endif
    enddo
    !
    ! A "trick" to ensure that "wet" points that were dry
    ! obtain a velocity (see also Z_CHECKU and Z_DIFU)
    !
    do nm = 1, nmmax
       if (kfs(nm) == 1) then
          if (kfsmin(nm) < kfsmn0(nm)) then
             do k = kfsmin(nm), kfsmn0(nm)-1
                w1(nm, k) = w1(nm, kfsmn0(nm))
             enddo
          elseif (kfsmin(nm) > kfsmn0(nm)) then
             do k = kfsmn0(nm), kfsmin(nm)-1
                w1(nm, k) = 0.0_fp
             enddo
          endif
          if (kfsmax(nm) > kfsmx0(nm)) then
             do k = kfsmx0(nm), kfsmax(nm)
                w1(nm, k) = w1(nm, kfsmx0(nm))
             enddo
          endif
       endif
    enddo
    do nm = 1, nmmax
       !
       ! Copy concentration to new layer. NB. KFS might be equal to zero!
       !
       if ((kcs(nm)==1 .or. kcs(nm)==-1) .and. kfsmax(nm) > kfsmx0(nm)) then
          do k = kfsmx0(nm)+1, kfsmax(nm)
             do l = 1, lstsci
                r1(nm, k, l) = r1(nm, kfsmx0(nm), l)
             enddo
          enddo
       endif
       !
       ! Copy concentration to bottom layer. NB. KFS might be equal to zero!
       !
       if (kcs(nm).eq.1 .and. kfsmin(nm) < kfsmn0(nm)) then
          do k = kfsmin(nm), kfsmn0(nm)-1
             do l = 1, lstsci
                r1(nm, k, l) = r1(nm, kfsmn0(nm), l)
             enddo
          enddo
       endif
    enddo
end subroutine z_drychk


subroutine ca_state_update( lo, hi, &
     state,state_l1,state_l2,state_h1,state_h2, &
     rhoe,  rhoe_l1, rhoe_l2, rhoe_h1, rhoe_h2, &
     temp,  temp_l1, temp_l2, temp_h1, temp_h2, &
     msk ,   msk_l1,  msk_l2,  msk_h1,  msk_h2, &
     derat, dTrat)

  use meth_params_module, only : NVAR, UEDEN, UEINT, UTEMP

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer, intent(in) :: lo(2), hi(2)
  integer, intent(in) :: state_l1, state_h1, state_l2, state_h2
  integer, intent(in) ::  rhoe_l1,  rhoe_h1,  rhoe_l2,  rhoe_h2
  integer, intent(in) ::  temp_l1,  temp_h1,  temp_l2,  temp_h2
  integer, intent(in) ::   msk_l1,   msk_h1,   msk_l2,   msk_h2
  real(rt)        , intent(in) :: rhoe( rhoe_l1: rhoe_h1, rhoe_l2: rhoe_h2)
  real(rt)        , intent(in) :: temp( temp_l1: temp_h1, temp_l2: temp_h2)
  real(rt)        , intent(in) ::  msk(  msk_l1:  msk_h1,  msk_l2:  msk_h2)
  real(rt)                     ::state(state_l1:state_h1,state_l2:state_h2,NVAR)
  real(rt)        , intent(inout) :: derat, dTrat

  integer :: i, j
  real(rt)         :: ei, ek, Told

  do j=lo(2), hi(2)
  do i=lo(1), hi(1)
     ei = state(i,j,UEINT)
     derat = max(derat, abs((rhoe(i,j) - ei)*msk(i,j)/ max(ei, 1.e-50_rt)))
     ek = state(i,j,UEDEN) - state(i,j,UEINT)
     state(i,j,UEINT) = rhoe(i,j)
     state(i,j,UEDEN) = rhoe(i,j) + ek

     Told = state(i,j,UTEMP);
     dTrat = max(dTrat, abs((temp(i,j)-Told)*msk(i,j)/ max(Told, 1.e-50_rt)))
     state(i,j,UTEMP) = temp(i,j)
  end do
  end do

end subroutine ca_state_update

subroutine ca_ncupdate_matter( lo, hi,  &
     Tp_n,Tp_n_l1,Tp_n_l2,Tp_n_h1,Tp_n_h2,  &
     Er_n,Er_n_l1,Er_n_l2,Er_n_h1,Er_n_h2,  &
     re_s,re_s_l1,re_s_l2,re_s_h1,re_s_h2,  &
     re_2,re_2_l1,re_2_l2,re_2_h1,re_2_h2,  &
     etTz,etTz_l1,etTz_l2,etTz_h1,etTz_h2,  &
      kpp, kpp_l1, kpp_l2, kpp_h1, kpp_h2,  &
       jg,  jg_l1,  jg_l2,  jg_h1,  jg_h2,  &
     dt)

  use rad_params_module, only : ngroups, clight

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer,intent(in)::lo(2),hi(2)
  integer,intent(in)::Tp_n_l1,Tp_n_h1,Tp_n_l2,Tp_n_h2
  integer,intent(in)::Er_n_l1,Er_n_h1,Er_n_l2,Er_n_h2
  integer,intent(in)::re_s_l1,re_s_h1,re_s_l2,re_s_h2
  integer,intent(in)::re_2_l1,re_2_h1,re_2_l2,re_2_h2
  integer,intent(in)::etTz_l1,etTz_h1,etTz_l2,etTz_h2
  integer,intent(in):: kpp_l1, kpp_h1, kpp_l2, kpp_h2
  integer,intent(in)::  jg_l1,  jg_h1,  jg_l2,  jg_h2
  real(rt)                   ::Tp_n(Tp_n_l1:Tp_n_h1,Tp_n_l2:Tp_n_h2)
  real(rt)        ,intent(in)::Er_n(Er_n_l1:Er_n_h1,Er_n_l2:Er_n_h2,0:ngroups-1)
  real(rt)        ,intent(in)::re_s(re_s_l1:re_s_h1,re_s_l2:re_s_h2)
  real(rt)        ,intent(in)::re_2(re_2_l1:re_2_h1,re_2_l2:re_2_h2)
  real(rt)        ,intent(in)::etTz(etTz_l1:etTz_h1,etTz_l2:etTz_h2)
  real(rt)        ,intent(in):: kpp( kpp_l1: kpp_h1, kpp_l2: kpp_h2,0:ngroups-1)
  real(rt)        ,intent(in)::  jg(  jg_l1:  jg_h1,  jg_l2:  jg_h2,0:ngroups-1)
  real(rt)        ,intent(in) :: dt

   integer :: i,j,g
   real(rt)         :: cdt1, cpT, scrch_re
   real(rt)         :: dTemp
   real(rt)        , parameter :: fac = 0.01e0_rt

   cdt1 = 1.e0_rt / (clight * dt)
   do j = lo(2), hi(2)
   do i = lo(1), hi(1)

      cpT = 0.e0_rt
      do g = 0, ngroups-1
         cpT = cpT + kpp(i,j,g)*Er_n(i,j,g) - jg(i,j,g)
      end do

      scrch_re = cpT - (re_s(i,j) - re_2(i,j)) * cdt1

      dTemp = etTz(i,j)*scrch_re

      if (abs(dTemp/(Tp_n(i,j)+1.e-50_rt)) > fac) then
         dTemp = sign(fac*Tp_n(i,j), dTemp)
      end if

     Tp_n(i,j) = Tp_n(i,j) + dTemp

  end do
  end do

end subroutine ca_ncupdate_matter

subroutine ca_flux_face2center( lo, hi, &
     t, t_l1, t_l2, t_h1, t_h2, &
     f, f_l1, f_l2, f_h1, f_h2, &
     x, x_l1, x_h1, nt, idim, iflx) bind(C, name="ca_flux_face2center")

  use rad_params_module, only : ngroups
  use amrex_fort_module, only : rt => amrex_real
  implicit none

  integer,intent(in):: lo(2), hi(2)
  integer,intent(in)::t_l1,t_h1,t_l2,t_h2
  integer,intent(in)::f_l1,f_h1,f_l2,f_h2
  integer,intent(in)::x_l1,x_h1
  integer,intent(in) :: nt, idim, iflx
  real(rt)                   ::t(t_l1:t_h1,t_l2:t_h2,0:nt-1)
  real(rt)        ,intent(in)::f(f_l1:f_h1,f_l2:f_h2)
  real(rt)        ,intent(in)::x(x_l1:x_h1)

  integer it, i, j

  it = idim*ngroups + iflx

  if (idim .eq. 0) then
     do j=lo(2), hi(2)
        do i=lo(1), hi(1)
           t(i,j,it) = (f(i,j)/(x(i)+1.e-50_rt) + f(i+1,j)/x(i+1)) * 0.5e0_rt
        end do
     end do
  else
     do j=lo(2), hi(2)
        do i=lo(1), hi(1)
           t(i,j,it) = (f(i,j)/x(i) + f(i,j+1)/x(i)) * 0.5e0_rt
        end do
     end do
  end if

end subroutine ca_flux_face2center

! =======================================================================
! used by the hyperbolic solver

subroutine ca_spalpha( lo, hi, &
     spa, spa_l1, spa_l2, spa_h1, spa_h2, &
     lmx, lmx_l1, lmx_l2, lmx_h1, lmx_h2, &
     lmy, lmy_l1, lmy_l2, lmy_h1, lmy_h2, &
     igroup) bind(C, name="ca_spalpha")

  use rad_params_module, only : ngroups
  use fluxlimiter_module, only : FLDalpha
  use amrex_fort_module, only : rt => amrex_real
  implicit none
  integer, intent(in) :: lo(2), hi(2)
  integer, intent(in) :: spa_l1, spa_h1, spa_l2, spa_h2
  integer, intent(in) :: lmx_l1, lmx_h1, lmx_l2, lmx_h2
  integer, intent(in) :: lmy_l1, lmy_h1, lmy_l2, lmy_h2
  integer, intent(in) :: igroup
  real(rt)                     :: spa(spa_l1:spa_h1,spa_l2:spa_h2)
  real(rt)        , intent(in) :: lmx(lmx_l1:lmx_h1,lmx_l2:lmx_h2,0:ngroups-1)
  real(rt)        , intent(in) :: lmy(lmy_l1:lmy_h1,lmy_l2:lmy_h2,0:ngroups-1)
  integer :: i,j
  real(rt)         :: lam

  do j = lo(2), hi(2)
  do i = lo(1), hi(1)
     if ( i.eq.spa_l1 .or. i.eq.spa_h1 .or.  &
          j.eq.spa_l2 .or. j.eq.spa_h2 ) then
        lam = 0.25e0_rt*(lmx(i,j,igroup) + lmx(i+1,j  ,igroup)  &
             +        lmy(i,j,igroup) + lmy(i  ,j+1,igroup))
        spa(i,j) = FLDalpha(lam)
     end if
  end do
  end do

end subroutine ca_spalpha